      SUBROUTINE SDBI3P(MD,NDP,XD,YD,ZD,NIP,XI,YI, ZI,IER, WK,IWK,
     +                  EXTRPI,NEAR,NEXT,DIST)

*
* Scattered-data bivariate interpolation
* (a master subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine performs bivariate interpolation when the data
* points are scattered in the x-y plane.  It is based on the
* revised Akima method that has the accuracy of a cubic (third-
* degree) polynomial.
*
* The input arguments are
*   MD  = mode of computation
*       = 1 for new XD-YD (default)
*       = 2 for old XD-YD, new ZD
*       = 3 for old XD-YD, old ZD,
*   NDP = number of data points (must be 10 or greater),
*   XD  = array of dimension NDP containing the x coordinates
*         of the data points,
*   YD  = array of dimension NDP containing the y coordinates
*         of the data points,
*   ZD  = array of dimension NDP containing the z values at
*         the data points,
*   NIP = number of output points at which interpolation is
*         to be performed (must be 1 or greater),
*   XI  = array of dimension NIP containing the x coordinates
*         of the output points,
*   YI  = array of dimension NIP containing the y coordinates
*         of the output points.
*
* The output arguments are
*   ZI  = array of dimension NIP, where interpolated z values
*         are to be stored,
*   IER = error flag
*       = 0 for no errors
*       = 1 for NDP = 9 or less
*       = 2 for NDP not equal to NDPPV
*       = 3 for NIP = 0 or less
*       = 9 for errors in SDTRAN called by this subroutine.
*
* The other arguments are
*   WK  = two-dimensional array of dimension NDP*17 used
*         internally as a work area,
*   IWK = two-dimensional integer array of dimension NDP*25
*         used internally as a work area.
*
* agebhard@uni-klu.ac.at: added from new TRIPACK:
*   NEAR, NEXT, DIST work arrays from TRMESH, size NDP
*
* The very first call to this subroutine and the call with a new
* NDP value or new XD and YD arrays must be made with MD=1.  The
* call with MD=2 must be preceded by another call with the same
* NDP value and same XD and YD arrays.  The call with MD=3 must
* be preceded by another call with the same NDP value and same
* XD, YD, and ZD arrays.  Between the call with MD=2 and its
* preceding call, the IWK array must not be disturbed.  Between
* the call with MD=3 and its preceding call, the WK and IWK
* arrays must not be disturbed.
*
* The user of this subroutine can save the storage, by NDP*6
* numerical storage units, by placing the statement
*     EQUIVALENCE (WK(1,1),IWK(1,20))
* in the program that calls this subroutine.
*
* The constant in the PARAMETER statement below is
*   NIPIMX = maximum number of output points to be processed
*            at a time.
* The constant value has been selected empirically.
*
* This subroutine calls the SDTRAN, SDPD3P, SDLCTN, and SDPLNL
* subroutines.
*
*
* Specification statements
*     .. Parameters ..
      INTEGER          NIPIMX
      PARAMETER        (NIPIMX=51)
*     ..
*     .. Scalar Arguments ..
      INTEGER          IER,MD,NDP,NIP,NEAR(NDP),NEXT(NDP)

*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             WK(NDP,17),XD(NDP),XI(NIP),YD(NDP),
     +                 YI(NIP),ZD(NDP),ZI(NIP),DIST(NDP)
      INTEGER          IWK(NDP,25)
      LOGICAL          EXTRPI(NIP)
*     ..
*     .. Local Scalars ..
      INTEGER          IERT,IIP,NDPPV,NIPI,NL,NT
*     ..
*     .. Local Arrays ..
      INTEGER          ITLI(NIPIMX),KTLI(NIPIMX)
*     ..
*     .. External Subroutines ..
      EXTERNAL         SDLCTN,SDPD3P,SDPLNL,SDTRAN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     ..
*     .. Save statement ..
      SAVE             NDPPV,NT,NL
*     ..
* Error check
      IF (NDP.LE.9) GO TO 20
      IF (MD.NE.2 .AND. MD.NE.3) THEN
          NDPPV = NDP
      ELSE
          IF (NDP.NE.NDPPV) GO TO 30
      END IF
      IF (NIP.LE.0) GO TO 40
* Triangulates the x-y plane.  (for MD=1)
      IF (MD.NE.2 .AND. MD.NE.3) THEN
          CALL SDTRAN(NDP,XD,YD, NT,IWK(1,1),NL,IWK(1,7),IERT,
     +                IWK(1,1),IWK(1,7),IWK(1,13),IWK(1,14),IWK(1,9),
     +                NEAR,NEXT,DIST)
*         CALL SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT,
*    +                LIST,LPTR,LEND,LTRI,ITL)
          IF (IERT.GT.0) GO TO 50
      END IF
* Estimates partial derivatives at all data points.  (for MD=1,2)
      IF (MD.NE.3) THEN
          CALL SDPD3P(NDP,XD,YD,ZD, WK(1,1), WK(1,6),WK(1,15),WK(1,17),
     +                IWK(1,9),IWK(1,10),IWK(1,19))
*         CALL SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP)
      END IF
* Locates all points at which interpolation is to be performed
* and interpolates the ZI values.  (for MD=1,2,3)
      DO 10 IIP = 1,NIP,NIPIMX
          NIPI = MIN(NIP-IIP+1,NIPIMX)
          CALL SDLCTN(NDP,XD,YD,NT,IWK(1,1),NL,IWK(1,7),NIPI,XI(IIP),
     +                YI(IIP), KTLI,ITLI)
*         CALL SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI)
          CALL SDPLNL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7),WK(1,1),NIPI,
     +                XI(IIP),YI(IIP),KTLI,ITLI, ZI(IIP), EXTRPI(IIP))
*         CALL SDPLNL(NDP,XD,YD,ZD,NT,IPT,NL,IPL,PDD,
*    +                NIP,XI,YI,KTLI,ITLI, ZI)
   10 CONTINUE
* Normal return
      IER = 0
      RETURN
* Error exit
   20 WRITE (*,FMT=9000) MD,NDP
      IER = 1
      RETURN
   30 WRITE (*,FMT=9010) MD,NDP,NDPPV
      IER = 2
      RETURN
   40 WRITE (*,FMT=9020) MD,NDP,NIP
      IER = 3
      RETURN
   50 WRITE (*,FMT=9030)
      IER = 9
      RETURN
* Format statement for error message
 9000 FORMAT (' ',/,'*** SDBI3P Error 1: NDP = 9 or less',/,'    MD =',
     +       I5,',  NDP =',I5,/)
 9010 FORMAT (' ',/,'*** SDBI3P Error 2: NDP not equal to NDPPV',/,
     +       '    MD =',I5,',  NDP =',I5,',  NDPPV =',I5,/)
 9020 FORMAT (' ',/,'*** SDBI3P Error 3: NIP = 0 or less',/,'    MD =',
     +       I5,',  NDP =',I5,',  NIP =',I5,/)
 9030 FORMAT ('    Error detected in SDTRAN called by SDBI3P',/)
      END


      SUBROUTINE SDSF3P(MD,NDP,XD,YD,ZD,NXI,XI,NYI,YI, ZI,IER, WK,IWK,
     +                  EXTRPI,NEAR,NEXT,DIST)
*
* Scattered-data smooth surface fitting
* (a master subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine performs smooth surface fitting when the data
* points are scattered in the x-y plane.  It is based on the
* revised Akima method that has the accuracy of a cubic (third-
* degree) polynomial.
*
* The input arguments are
*   MD  = mode of computation
*       = 1 for new XD-YD (default)
*       = 2 for old XD-YD, new ZD
*       = 3 for old XD-YD, old ZD,
*   NDP = number of data points (must be 10 or greater),
*   XD  = array of dimension NDP containing the x coordinates
*         of the data points,
*   YD  = array of dimension NDP containing the y coordinates
*         of the data points,
*   ZD  = array of dimension NDP containing the z values at
*         the data points,
*   NXI = number of output grid points in the x coordinate
*         (must be 1 or greater),
*   XI  = array of dimension NXI containing the x coordinates
*         of the output grid points,
*   NYI = number of output grid points in the y coordinate
*         (must be 1 or greater),
*   YI  = array of dimension NYI containing the y coordinates
*         of the output grid points.
*
* The output arguments are
*   ZI  = two-dimensional array of dimension NXI*NYI, where
*         the interpolated z values at the output grid points
*         are to be stored,
*   IER = error flag
*       = 0 for no errors
*       = 1 for NDP = 9 or less
*       = 2 for NDP not equal to NDPPV
*       = 3 for NXI = 0 or less
*       = 4 for NYI = 0 or less
*       = 9 for errors in SDTRAN called by this subroutine.
*
* The other arguments are
*   WK  = two-dimensional array of dimension NDP*36 used
*         internally as a work area,
*   IWK = two-dimensional integer array of dimension NDP*25
*         used internally as a work area.
*
* agebhard@uni-klu.ac.at: added from new TRIPACK:
*   NEAR, NEXT, DIST work arrays from TRMESH, size NDP
*
* The very first call to this subroutine and the call with a new
* NDP value or new XD and YD arrays must be made with MD=1.  The
* call with MD=2 must be preceded by another call with the same
* NDP value and same XD and YD arrays.  The call with MD=3 must
* be preceded by another call with the same NDP value and same
* XD, YD, and ZD arrays.  Between the call with MD=2 and its
* preceding call, the IWK array must not be disturbed.  Between
* the call with MD=3 and its preceding call, the WK and IWK
* arrays must not be disturbed.
*
* The user of this subroutine can save the storage, by NDP*6
* numeric storage units, by placing the statement
*     EQUIVALENCE (WK(1,1),IWK(1,20))
* in the program that calls this subroutine.
*
* The constant in the PARAMETER statement below is
*   NIPIMX = maximum number of output points to be processed
*            at a time.
* The constant value has been selected empirically.
*
* This subroutine calls the SDTRAN, SDPD3P, SDLCTN, and SDPLNL
* subroutines.
*
*
* Specification statements
*     .. Parameters ..
      INTEGER          NIPIMX
      PARAMETER        (NIPIMX=51)
*     ..
*     .. Scalar Arguments ..
      INTEGER          IER,MD,NDP,NXI,NYI,NEAR(NDP),NEXT(NDP)
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             WK(NDP,17),XD(NDP),XI(NXI),YD(NDP),
     +                 YI(NYI),ZD(NDP),ZI(NXI,NYI),DIST(NDP)
      INTEGER          IWK(NDP,25)
      LOGICAL          EXTRPI(NXI,NYI)
*     ..
*     .. Local Scalars ..
      INTEGER          IERT,IIP,IXI,IYI,NDPPV,NIPI,NL,NT
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION             YII(NIPIMX)
      INTEGER          ITLI(NIPIMX),KTLI(NIPIMX)
*     ..
*     .. External Subroutines ..
      EXTERNAL         SDLCTN,SDPD3P,SDPLNL,SDTRAN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     ..
*     .. Save statement ..
      SAVE             NDPPV,NT,NL
*     ..
* Error check
      IF (NDP.LE.9) GO TO 40
      IF (MD.NE.2 .AND. MD.NE.3) THEN
          NDPPV = NDP
      ELSE
          IF (NDP.NE.NDPPV) GO TO 50
      END IF
      IF (NXI.LE.0) GO TO 60
      IF (NYI.LE.0) GO TO 70
* Triangulates the x-y plane.  (for MD=1)
      IF (MD.NE.2 .AND. MD.NE.3) THEN
          CALL SDTRAN(NDP,XD,YD, NT,IWK(1,1),NL,IWK(1,7),IERT,
     +                IWK(1,1),IWK(1,7),IWK(1,13),IWK(1,14),IWK(1,9),
     +                NEAR,NEXT,DIST)
*         CALL SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT,
*    +                LIST,LPTR,LEND,LTRI,ITL)
          IF (IERT.GT.0) GO TO 80
      END IF
* Estimates partial derivatives at all data points.  (for MD=1,2)
      IF (MD.NE.3) THEN
          CALL SDPD3P(NDP,XD,YD,ZD, WK(1,1), WK(1,6),WK(1,15),WK(1,17),
     +                IWK(1,9),IWK(1,10),IWK(1,19))
*         CALL SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP)
      END IF
* Locates all grid points at which interpolation is to be
* performed and interpolates the ZI values.  (for MD=1,2,3)
      DO 30 IYI = 1,NYI
          DO 10 IIP = 1,NIPIMX
              YII(IIP) = YI(IYI)
   10     CONTINUE
          DO 20 IXI = 1,NXI,NIPIMX
              NIPI = MIN(NXI-IXI+1,NIPIMX)
              CALL SDLCTN(NDP,XD,YD,NT,IWK(1,1),NL,IWK(1,7),NIPI,
     +                    XI(IXI),YII, KTLI,ITLI)
*             CALL SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI)
              CALL SDPLNL(NDP,XD,YD,ZD,NT,IWK(1,1),NL,IWK(1,7),WK(1,1),
     +                    NIPI,XI(IXI),YII,KTLI,ITLI, ZI(IXI,IYI),
     +                    EXTRPI(IXI,IYI))
*             CALL SDPLNL(NDP,XD,YD,ZD,NT,ITP,NL,IPL,PDD,
*    +                    NIP,XI,YI,KTLI,ITLI, ZI)
   20     CONTINUE
   30 CONTINUE
* Normal return
      IER = 0
      RETURN
* Error exit
   40 WRITE (*,FMT=9000) MD,NDP
      IER = 1
      RETURN
   50 WRITE (*,FMT=9010) MD,NDP,NDPPV
      IER = 2
      RETURN
   60 WRITE (*,FMT=9020) MD,NDP,NXI,NYI
      IER = 3
      RETURN
   70 WRITE (*,FMT=9030) MD,NDP,NXI,NYI
      IER = 4
      RETURN
   80 WRITE (*,FMT=9040)
      IER = 9
      RETURN
* Format statement for error message
 9000 FORMAT (' ',/,'*** SDSF3P Error 1: NDP = 9 or less',/,'    MD =',
     +       I5,',  NDP =',I5,/)
 9010 FORMAT (' ',/,'*** SDSF3P Error 2: NDP not equal to NDPPV',/,
     +       '    MD =',I5,',  NDP =',I5,'  NDPPV =',I5,/)
 9020 FORMAT (' ',/,'*** SDSF3P Error 3: NXI = 0 or less',/,'    MD =',
     +       I5,',  NDP =',I5,'  NXI =',I5,',  NYI =',I5,/)
 9030 FORMAT (' ',/,'*** SDSF3P Error 4: NYI = 0 or less',/,'    MD =',
     +       I5,',  NDP =',I5,'  NXI =',I5,',  NYI =',I5,/)
 9040 FORMAT ('    Error detected in SDTRAN called by SDSF3P',/)
      END


      SUBROUTINE SDTRAN(NDP,XD,YD, NT,IPT,NL,IPL,IERT, LIST,LPTR,LEND,
     +                  LTRI,ITL,NEAR,NEXT,DIST)
*
* Triangulation of the data area in a plane with a scattered data
* point set
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine triangulates the data area in the x-y plane with
* a scattered data point set.  It divides the data area into a
* number of triangles and determines line segments that form the
* border of the data area.
*
* This subroutine consists of the following two steps, i.e.,
* (1) basic triangulation in the convex hull of the data points,
* and (2) removal of thin triangles along the border line of the
* data area.  It calls the SDTRCH and SDTRTT subroutines, that
* correspond to Steps (1) and (2), respectively.
*
* The input arguments are
*   NDP  = number of data points (must be greater than 3),
*   XD   = array of dimension NDP containing the x
*          coordinates of the data points,
*   YD   = array of dimension NDP containing the y
*          coordinates of the data points.
*
* The output arguments are
*   NT   = number of triangles (its maximum is 2*NDP-5),
*   IPT  = two-dimensional integer array of dimension
*          (3,NT), where the point numbers of the vertexes
*          of the ITth triangle are to be stored counter-
*          clockwise in the ITth column, where IT = 1, 2,
*          ..., NT,
*   NL   = number of border line segments (its maximum is
*          NDP),
*   IPL  = two-dimensional integer array of dimension
*          (2,NL), where the point numbers of the end
*          points of the (IL)th border line segment are to
*          be stored counterclockwise in the ILth column,
*          where IL = 1, 2, ..., NL, with the line segments
*          stored counterclockwise,
*   IERT = error flag
*        = 0 for no errors
*        = 1 for NDP = 3 or less
*        = 2 for identical data points
*        = 3 for all collinear data points.
*
* The other arguments are
*   LIST = integer array of dimension 6*NDP USED internally
*          as a work area,
*   LPTR = integer array of dimension 6*NDP USED internally
*          as a work area,
*   LEND = integer array of dimension NDP USED internally as
*          a work area,
*   LTRI = two-dimensional integer array of dimension 12*NDP
*          used internally as a work area.
*   ITL  = integer array of dimension NDP used internally as
*          a work area.
*
* agebhard@uni-klu.ac.at: added from new TRIPACK:
*   NEAR, NEXT, DIST work arrays from TRMESH, size NDP
*
*
* Specification statements
*     .. Scalar Arguments ..
      INTEGER          IERT,NDP,NL,NT,NEAR(NDP),NEXT(NDP)
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             XD(NDP),YD(NDP),DIST(NDP)
      INTEGER          IPL(2,*),IPT(3,*),ITL(NDP),LEND(NDP),LIST(6,NDP),
     +                 LPTR(6,NDP),LTRI(12,NDP)
*     ..
*     .. Local Scalars ..
      INTEGER          IERTL,IERTM,IP1
*     ..
*     .. External Subroutines ..
      EXTERNAL         SDTRCH,SDTRTT
*     ..
* Basic triangulation
      CALL SDTRCH(NDP,XD,YD, NT,IPT,NL,IPL,IERTM,IERTL, LIST,LPTR,LEND,
     +            LTRI,NEAR,NEXT,DIST)
      IF (IERTM.NE.0) GO TO 10
      IF (IERTL.NE.0) GO TO 20
      IERT = 0
* Removal of thin triangles that share border line segments
      CALL SDTRTT(NDP,XD,YD, NT,IPT,NL,IPL, ITL)
      RETURN
* Error exit
   10 IF (IERTM.EQ.-1) THEN
          IERT = 1
          WRITE (*,FMT=9000) NDP
      ELSE IF (IERTM.EQ.-2) THEN
          IERT = 2
          WRITE (*,FMT=9010)
      ELSE
          IERT = 3
          IP1 = IERTM
          WRITE (*,FMT=9020) NDP,IP1,XD(IP1),YD(IP1)
      END IF
      RETURN
   20 IF (IERTL.EQ.1) THEN
          IERT = 4
          WRITE (*,FMT=9030) NDP
      ELSE IF (IERTL.EQ.2) THEN
          IERT = 5
          WRITE (*,FMT=9040)
      END IF
      RETURN
* Format statements
 9000 FORMAT (' ',/,'*** SDTRAN Error 1: NDP = 3 or less',/,'    NDP =',
     +       I5)
 9010 FORMAT (' ',/,'*** SDTRAN Error 2: ',
     +       'The first three data points are collinear.',/)
 9020 FORMAT (' ',/,'*** SDTRAN Error 3: Identical data points',/,
     +       '    NDP =',I5,',  IP1 =',I5,',  XD =',E11.3,',  YD =',
     +       E11.3)
 9030 FORMAT (' ',/,'*** SDTRAN Error 4: NDP outside its valid',
     +       ' range',/,'    NDP =',I5)
 9040 FORMAT (' ',/,'*** SDTRAN Error 5: ',
     +       'Invalid data structure (LIST,LPTR,LEND)',/)
      END


      SUBROUTINE SDTRCH(NDP,XD,YD, NT,IPT,NL,IPL,IERTM,IERTL,
     +                  LIST,LPTR,LEND,LTRI,NEAR,NEXT,DIST)
*
* Basic triangulation in the convex hull of a scattered data point
* set in a plane
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine triangulates the data area that is a convex hull
* of the scattered data points in the x-y plane.  It divides the
* data area into a number of triangles and determines line segments
* that form the border of the data area.
*
* This subroutine depends on the TRIPACK package of ACM Algorithm
* 751 by R. J. Renka.  It calls the TRMESH and TRLIST subroutines
* included in the package.  The TRMESH subroutine in turn calls
* either directly or indirectly 12 other subprograms included in
* the package.
*
* The input arguments are
*   NDP   = number of data points (must be greater than 3),
*   XD    = array of dimension NDP containing the x
*           coordinates of the data points,
*   YD    = array of dimension NDP containing the y
*           coordinates of the data points.
*
* The output arguments are
*   NT    = number of triangles (its maximum is 2*NDP-5),
*   IPT   = two-dimensional integer array of dimension
*           (3,NT), where the point numbers of the vertexes
*           of the ITth triangle are to be stored counter-
*           clockwise in the ITth column, where IT = 1, 2,
*           ..., NT,
*   NL    = number of border line segments (its maximum is
*           NDP),
*   IPL   = two-dimensional integer array of dimension
*           (2,NL), where the point numbers of the end
*           points of the (IL)th border line segment are to
*           be stored counterclockwise in the ILth column,
*           where IL = 1, 2, ..., NL, with the line segments
*           stored counterclockwise,
*   IERTM = error flag from the TRMESH subroutine,
*         =  0 for no errors
*         = -1 for NDP = 3 or less
*         = -2 for the first three collinear data points,
*         =  L for the Lth data point identical to some
*            Mth data point, M > L.
*   IERTL = error flag from the TRLIST subroutine,
*         = 0 for no errors
*         = 1 for invalid NCC, NDP, or NROW value.
*         = 2 for invalid data structure (LIST,LPTR,LEND).
*
* The other arguments are
*   LIST  = integer array of dimension 6*NDP USED internally
*           as a work area,
*   LPTR  = integer array of dimension 6*NDP USED internally
*           as a work area,
*   LEND  = integer array of dimension NDP USED internally as
*           a work area,
*   LTRI  = two-dimensional integer array of dimension 12*NDP
*           used internally as a work area.
*
* agebhard@uni-klu.ac.at: added from new TRIPACK:
*   NEAR, NEXT, DIST work arrays from TRMESH, size NDP
*
* Specification statements
*     .. Parameters ..
      INTEGER          NCC,NROW
      PARAMETER        (NCC=0,NROW=6)
*     ..
*     .. Scalar Arguments ..
      INTEGER          IERTL,IERTM,NDP,NL,NT,NEAR(NDP),NEXT(NDP)
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             XD(NDP),YD(NDP),DIST(NDP)
      INTEGER          IPL(2,*),IPT(3,*),LEND(NDP),LIST(*),LPTR(*),
     +                 LTRI(NROW,*)
*     ..
*     .. Local Scalars ..
      INTEGER          I,I1,I2,IL,IL1,IL2,IPL11,IPL21,J,LNEW
*     ..
*     .. Local Arrays ..
      INTEGER          LCC(1),LCT(1)
*     ..
*     .. External Subroutines ..
      EXTERNAL         TRLIST,TRMESH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        MOD
*     ..
* Performs basic triangulation.
      CALL TRMESH(NDP,XD,YD, LIST,LPTR,LEND,LNEW,NEAR,NEXT,DIST,IERTM)
      IF (IERTM.NE.0) RETURN
      CALL TRLIST(NCC,LCC,NDP,LIST,LPTR,LEND,NROW, NT,LTRI,LCT,IERTL)
      IF (IERTL.NE.0) RETURN
* Extracts the triangle data from the LTRI array and set the IPT
* array.
      DO 20 J = 1,NT
          DO 10 I = 1,3
              IPT(I,J) = LTRI(I,J)
   10     CONTINUE
   20 CONTINUE
* Extracts the border-line-segment data from the LTRI array and
* set the IPL array.
      IL = 0
      DO 50 J = 1,NT
          DO 30 I = 1,3
              IF (LTRI(I+3,J).LE.0) GO TO 40
   30     CONTINUE
          GO TO 50
   40     IL = IL + 1
          I1 = MOD(I,3) + 1
          I2 = MOD(I+1,3) + 1
          IPL(1,IL) = LTRI(I1,J)
          IPL(2,IL) = LTRI(I2,J)
   50 CONTINUE
      NL = IL
* Sorts the IPL array.
      DO 80 IL1 = 1,NL - 1
          DO 60 IL2 = IL1 + 1,NL
              IF (IPL(1,IL2).EQ.IPL(2,IL1)) GO TO 70
   60     CONTINUE
   70     IPL11 = IPL(1,IL1+1)
          IPL21 = IPL(2,IL1+1)
          IPL(1,IL1+1) = IPL(1,IL2)
          IPL(2,IL1+1) = IPL(2,IL2)
          IPL(1,IL2) = IPL11
          IPL(2,IL2) = IPL21
   80 CONTINUE
      RETURN
      END


      SUBROUTINE SDTRTT(NDP,XD,YD, NT,IPT,NL,IPL, ITL)
*
* Removal of thin triangles along the border line of triangulation
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine removes thin triangles along the border line of
* triangulation.
*
* The input arguments are
*   NDP = number of data points (must be greater than 3),
*   XD  = array of dimension NDP containing the x
*         coordinates of the data points,
*   YD  = array of dimension NDP containing the y
*         coordinates of the data points.
*
* The input and output arguments are
*   NT  = number of triangles (its maximum is 2*NDP-5),
*   IPT = two-dimensional integer array of dimension
*         (3,NT), where the point numbers of the vertexes
*         of the ITth triangle are to be stored counter-
*         clockwise in the ITth column, where IT = 1, 2,
*         ..., NT,
*   NL  = number of border line segments (its maximum is
*         NDP),
*   IPL = two-dimensional integer array of dimension
*         (2,NL), where the point numbers of the end
*         points of the (IL)th border line segment are to
*         be stored counterclockwise in the ILth column,
*         where IL = 1, 2, ..., NL, with the line segments
*         stored counterclockwise.
*
* The other argument is
*   ITL = integer array of dimension NDP used internally as
*         a work area.
*
* The constants in the PARAMETER statement below are
*   HBRMN = minimum value of the height-to-bottom ratio of a
*           triangle along the border line of the data area,
*   NRRTT = number of repetitions in thin triangle removal.
* The constant values have been selected empirically.
*
* Specification statements
*     .. Parameters ..
      DOUBLE PRECISION             HBRMN
      INTEGER          NRRTT
      PARAMETER        (HBRMN=0.10,NRRTT=5)
*     ..
*     .. Scalar Arguments ..
      INTEGER          NDP,NL,NT
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             XD(NDP),YD(NDP)
      INTEGER          IPL(2,*),IPT(3,*),ITL(NDP)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION             HBR,U1,U2,U3,V1,V2,V3
      INTEGER          IL,IL0,IL00,IL1,ILP1,ILR1,IP1,IP2,IP3,IPL1,IPL2,
     +                 IREP,IT,IT0,ITP1,IV,IVP1,MODIF,NL0
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        MOD
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION             DSQF,VPDT
*     ..
* Statement Function definitions
      DSQF(U1,V1,U2,V2) = (U2-U1)**2 + (V2-V1)**2
      VPDT(U1,V1,U2,V2,U3,V3) = (V3-V1)* (U2-U1) - (U3-U1)* (V2-V1)
*     ..
* Triangle numbers of triangles that share line segments with the
* border line.
      DO 20 IL = 1,NL
          IPL1 = IPL(1,IL)
          IPL2 = IPL(2,IL)
          DO 10 IT = 1,NT
              IF (IPL1.EQ.IPT(1,IT) .OR. IPL1.EQ.IPT(2,IT) .OR.
     +            IPL1.EQ.IPT(3,IT)) THEN
                  IF (IPL2.EQ.IPT(1,IT) .OR. IPL2.EQ.IPT(2,IT) .OR.
     +                IPL2.EQ.IPT(3,IT)) THEN
                      ITL(IL) = IT
                      GO TO 20
                  END IF
              END IF
   10     CONTINUE
   20 CONTINUE
* Removes thin triangles that share line segments with the border
* line.
      DO 130 IREP = 1,NRRTT
          MODIF = 0
          NL0 = NL
          IL = 0
          DO 120 IL0 = 1,NL0
              IL = IL + 1
              IP1 = IPL(1,IL)
              IP2 = IPL(2,IL)
              IT = ITL(IL)
* Calculates the height-to-bottom ratio of the triangle.
              IF (IPT(1,IT).NE.IP1 .AND. IPT(1,IT).NE.IP2) THEN
                  IP3 = IPT(1,IT)
              ELSE IF (IPT(2,IT).NE.IP1 .AND. IPT(2,IT).NE.IP2) THEN
                  IP3 = IPT(2,IT)
              ELSE
                  IP3 = IPT(3,IT)
              END IF
              HBR = VPDT(XD(IP1),YD(IP1),XD(IP2),YD(IP2),XD(IP3),
     +              YD(IP3))/DSQF(XD(IP1),YD(IP1),XD(IP2),YD(IP2))
              IF (HBR.LT.HBRMN) THEN
                  MODIF = 1
* Removes this triangle when applicable.
                  ITP1 = IT + 1
                  DO 30 IT0 = ITP1,NT
                      IPT(1,IT0-1) = IPT(1,IT0)
                      IPT(2,IT0-1) = IPT(2,IT0)
                      IPT(3,IT0-1) = IPT(3,IT0)
   30             CONTINUE
                  NT = NT - 1
                  DO 40 IL00 = 1,NL
                      IF (ITL(IL00).GT.IT) ITL(IL00) = ITL(IL00) - 1
   40             CONTINUE
* Replaces the border line segment with two new line segments.
                  IF (IL.LT.NL) THEN
                      ILP1 = IL + 1
                      DO 50 ILR1 = ILP1,NL
                          IL1 = NL + ILP1 - ILR1
                          IPL(1,IL1+1) = IPL(1,IL1)
                          IPL(2,IL1+1) = IPL(2,IL1)
                          ITL(IL1+1) = ITL(IL1)
   50                 CONTINUE
                  END IF
* - Adds the first new line segment.
                  IPL(1,IL) = IP1
                  IPL(2,IL) = IP3
                  DO 70 IT0 = 1,NT
                      DO 60 IV = 1,3
                          IF (IPT(IV,IT0).EQ.IP1 .OR.
     +                        IPT(IV,IT0).EQ.IP3) THEN
                              IVP1 = MOD(IV,3) + 1
                              IF (IPT(IVP1,IT0).EQ.IP1 .OR.
     +                            IPT(IVP1,IT0).EQ.IP3) GO TO 80
                          END IF
   60                 CONTINUE
   70             CONTINUE
   80             ITL(IL) = IT0
* - Adds the second new line segment.
                  IL = IL + 1
                  IPL(1,IL) = IP3
                  IPL(2,IL) = IP2
                  DO 100 IT0 = 1,NT
                      DO 90 IV = 1,3
                          IF (IPT(IV,IT0).EQ.IP3 .OR.
     +                        IPT(IV,IT0).EQ.IP2) THEN
                              IVP1 = MOD(IV,3) + 1
                              IF (IPT(IVP1,IT0).EQ.IP3 .OR.
     +                            IPT(IVP1,IT0).EQ.IP2) GO TO 110
                          END IF
   90                 CONTINUE
  100             CONTINUE
  110             ITL(IL) = IT0
                  NL = NL + 1
              END IF
  120     CONTINUE
          IF (MODIF.EQ.0) RETURN
  130 CONTINUE
      RETURN
      END


      SUBROUTINE SDPD3P(NDP,XD,YD,ZD, PDD, CF3,CFL1,DSQ,IDSQ,IPC,NCP)
*
* Partial derivatives for bivariate interpolation and surface
* fitting for scattered data
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine estimates partial derivatives of the first and
* second orders at the data points for bivariate interpolation
* and surface fitting for scattered data.  In most cases, this
* subroutine has the accuracy of a cubic (third-degree)
* polynomial.
*
* The input arguments are
*   NDP  = number of data points,
*   XD   = array of dimension NDP containing the x
*          coordinates of the data points,
*   YD   = array of dimension NDP containing the y
*          coordinates of the data points,
*   ZD   = array of dimension NDP containing the z values
*          at the data points.
*
* The output argument is
*   PDD  = two-dimensional array of dimension 5*NDP, where
*          the estimated zx, zy, zxx, zxy, and zyy values
*          at the IDPth data point are to be stored in the
*          IDPth row, where IDP = 1, 2, ..., NDP.
*
* The other arguments are
*   CF3  = two-dimensional array of dimension 9*NDP used
*          internally as a work area,
*   CFL1 = two-dimensional array of dimension 2*NDP used
*          internally as a work area,
*   DSQ  = array of dimension NDP used internally as a work
*          area,
*   IDSQ = integer array of dimension NDP used internally
*          as a work area,
*   IPC  = two-dimensional integer array of dimension 9*NDP
*          used internally as a work area,
*   NCP  = integer array of dimension NDP used internally
*          as a work area.
*
* The constant in the first PARAMETER statement below is
*   NPEMX = maximum number of primary estimates.
* The constant value has been selected empirically.
*
* The constants in the second PARAMETER statement below are
*   NPEAMN = minimum number of primary estimates,
*   NPEAMX = maximum number of primary estimates when
*            additional primary estimates are added.
* The constant values have been selected empirically.
*
* This subroutine calls the SDCLDP, SDCF3P, and SDLS1P
* subroutines.
*
*
* Specification statements
*     .. Parameters ..
      INTEGER          NPEMX
      PARAMETER        (NPEMX=25)
      INTEGER          NPEAMN,NPEAMX
      PARAMETER        (NPEAMN=3,NPEAMX=6)
*     ..
*     .. Scalar Arguments ..
      INTEGER          NDP
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             CF3(9,NDP),CFL1(2,NDP),DSQ(NDP),
     +                 PDD(5,NDP),XD(NDP),YD(NDP),ZD(NDP)
      INTEGER          IDSQ(NDP),IPC(9,NDP),NCP(NDP)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION             A01,A02,A03,A10,A11,A12,A20,A21,A30,
     +                 ALPWT,ANPE,ANPEM1,SMWTF,SMWTI,WTF,WTI,X,Y,ZX,ZY
      INTEGER          IDP1,IDP2,IDPI,IDPPE1,IMN,IPE,IPE1,J,J1,J2,JJ,
     +                 JMN,K,NCP2,NCP2P1,NPE
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION             AMPDPE(5),PDDIF(5),PDDII(5),
     +                 PDPE(5,NPEMX),PWT(NPEMX),RVWT(NPEMX),SSPDPE(5)
      INTEGER          IDPPE(NPEMX),IPCPE(10,NPEMX)
*     ..
*     .. External Subroutines ..
      EXTERNAL         SDCF3P,SDCLDP,SDLS1P
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        EXP,DBLE
*     ..
* Calculation
* Selects, at each of the data points, nine data points closest
* to the data point in question.
      CALL SDCLDP(NDP,XD,YD, IPC, DSQ,IDSQ)
* Fits, at each of the data points, a cubic (third-degree)
* polynomial to z values at the 10 data points that consist of
* the data point in question and 9 data points closest to it.
      CALL SDCF3P(NDP,XD,YD,ZD,IPC, CF3,NCP)
* Performs, at each of the data points, the least-squares fit of
* a plane to z values at the 10 data points.
      CALL SDLS1P(NDP,XD,YD,ZD,IPC,NCP, CFL1)
* Outermost DO-loop with respect to the data point
      DO 310 IDP1 = 1,NDP
* Selects data point sets for sets of primary estimates of partial
* derivatives.
* - Selects a candidate.
          NPE = 0
          DO 80 IDP2 = 1,NDP
              NCP2 = NCP(IDP2)
              NCP2P1 = NCP2 + 1
              IF (IDP2.EQ.IDP1) GO TO 20
              DO 10 J = 1,NCP2
                  IF (IPC(J,IDP2).EQ.IDP1) GO TO 20
   10         CONTINUE
              GO TO 80
   20         IPCPE(1,NPE+1) = IDP2
              DO 30 J = 1,NCP2
                  IPCPE(J+1,NPE+1) = IPC(J,IDP2)
   30         CONTINUE
              DO 50 J1 = 1,NCP2
                  JMN = J1
                  IMN = IPCPE(JMN,NPE+1)
                  DO 40 J2 = J1,NCP2P1
                      IF (IPCPE(J2,NPE+1).LT.IMN) THEN
                          JMN = J2
                          IMN = IPCPE(JMN,NPE+1)
                      END IF
   40             CONTINUE
                  IPCPE(JMN,NPE+1) = IPCPE(J1,NPE+1)
                  IPCPE(J1,NPE+1) = IMN
   50         CONTINUE
* - Checks whether or not the candidate has already been included.
              IF (NPE.GT.0) THEN
                  DO 70 IPE1 = 1,NPE
                      IDPPE1 = IDPPE(IPE1)
                      IF (NCP2.NE.NCP(IDPPE1)) GO TO 70
                      DO 60 J = 1,NCP2P1
                          IF (IPCPE(J,NPE+1).NE.
     +                        IPCPE(J,IPE1)) GO TO 70
   60                 CONTINUE
                      GO TO 80
   70             CONTINUE
              END IF
              NPE = NPE + 1
              IDPPE(NPE) = IDP2
              IF (NPE.GE.NPEMX) GO TO 90
   80     CONTINUE
   90     CONTINUE
* Adds additional closest data points when necessary.
          IF (NPE.LT.NPEAMN) THEN
              DO 150 JJ = 1,9
                  IDP2 = IPC(JJ,IDP1)
                  NCP2 = NCP(IDP2)
                  NCP2P1 = NCP2 + 1
                  IPCPE(1,NPE+1) = IDP2
                  DO 100 J = 1,NCP2
                      IPCPE(J+1,NPE+1) = IPC(J,IDP2)
  100             CONTINUE
                  DO 120 J1 = 1,NCP2
                      JMN = J1
                      IMN = IPCPE(JMN,NPE+1)
                      DO 110 J2 = J1,NCP2P1
                          IF (IPCPE(J2,NPE+1).LT.IMN) THEN
                              JMN = J2
                              IMN = IPCPE(JMN,NPE+1)
                          END IF
  110                 CONTINUE
                      IPCPE(JMN,NPE+1) = IPCPE(J1,NPE+1)
                      IPCPE(J1,NPE+1) = IMN
  120             CONTINUE
                  IF (NPE.GT.0) THEN
                      DO 140 IPE1 = 1,NPE
                          IDPPE1 = IDPPE(IPE1)
                          IF (NCP2.NE.NCP(IDPPE1)) GO TO 140
                          DO 130 J = 1,NCP2P1
                              IF (IPCPE(J,NPE+1).NE.
     +                            IPCPE(J,IPE1)) GO TO 140
  130                     CONTINUE
                          GO TO 150
  140                 CONTINUE
                  END IF
                  NPE = NPE + 1
                  IDPPE(NPE) = IDP2
                  IF (NPE.GE.NPEAMX) GO TO 160
  150         CONTINUE
          END IF
  160     CONTINUE
* Calculates the primary estimates of partial derivatives.
          X = XD(IDP1)
          Y = YD(IDP1)
          DO 170 IPE = 1,NPE
              IDPI = IDPPE(IPE)
              A10 = CF3(1,IDPI)
              A20 = CF3(2,IDPI)
              A30 = CF3(3,IDPI)
              A01 = CF3(4,IDPI)
              A11 = CF3(5,IDPI)
              A21 = CF3(6,IDPI)
              A02 = CF3(7,IDPI)
              A12 = CF3(8,IDPI)
              A03 = CF3(9,IDPI)
              PDPE(1,IPE) = A10 + X* (2.0*A20+X*3.0*A30) +
     +                      Y* (A11+2.0*A21*X+A12*Y)
              PDPE(2,IPE) = A01 + Y* (2.0*A02+Y*3.0*A03) +
     +                      X* (A11+2.0*A12*Y+A21*X)
              PDPE(3,IPE) = 2.0*A20 + 6.0*A30*X + 2.0*A21*Y
              PDPE(4,IPE) = A11 + 2.0*A21*X + 2.0*A12*Y
              PDPE(5,IPE) = 2.0*A02 + 6.0*A03*Y + 2.0*A12*X
  170     CONTINUE
          IF (NPE.EQ.1) GO TO 290
* Weighted values of partial derivatives (through the statement
* labeled 280 + 1)
* Calculates the probability weight.
          ANPE = DBLE(NPE)
          ANPEM1 = DBLE(NPE-1)
          DO 190 K = 1,5
              AMPDPE(K) = 0.0
              SSPDPE(K) = 0.0
              DO 180 IPE = 1,NPE
                  AMPDPE(K) = AMPDPE(K) + PDPE(K,IPE)
                  SSPDPE(K) = SSPDPE(K) + PDPE(K,IPE)**2
  180         CONTINUE
              AMPDPE(K) = AMPDPE(K)/ANPE
              SSPDPE(K) = (SSPDPE(K)-ANPE*AMPDPE(K)**2)/ANPEM1
  190     CONTINUE
          DO 210 IPE = 1,NPE
              ALPWT = 0.0
              DO 200 K = 1,5
                  IF (SSPDPE(K).NE.0.0) ALPWT = ALPWT +
     +                ((PDPE(K,IPE)-AMPDPE(K))**2)/SSPDPE(K)
  200         CONTINUE
              PWT(IPE) = EXP(-ALPWT/2.0)
  210     CONTINUE
* Calculates the reciprocal of the volatility weight.
          DO 220 IPE = 1,NPE
              IDPI = IDPPE(IPE)
              ZX = CFL1(1,IDPI)
              ZY = CFL1(2,IDPI)
              RVWT(IPE) = ((PDPE(1,IPE)-ZX)**2+ (PDPE(2,IPE)-ZY)**2)*
     +                    (PDPE(3,IPE)**2+2.0*PDPE(4,IPE)**2+
     +                    PDPE(5,IPE)**2)
*             ZXX=0.0
*             ZXY=0.0
*             ZYY=0.0
*             RVWT(IPE)=((PDPE(1,IPE)-ZX)**2+(PDPE(2,IPE)-ZY)**2)
*    +                 *((PDPE(3,IPE)-ZXX)**2+2.0*(PDPE(4,IPE)-ZXY)**2
*    +                  +(PDPE(5,IPE)-ZYY)**2)
  220     CONTINUE
* Calculates the weighted values of partial derivatives.
          DO 230 K = 1,5
              PDDIF(K) = 0.0
              PDDII(K) = 0.0
  230     CONTINUE
          SMWTF = 0.0
          SMWTI = 0.0
          DO 260 IPE = 1,NPE
              IF (RVWT(IPE).GT.0.0) THEN
                  WTF = PWT(IPE)/RVWT(IPE)
                  DO 240 K = 1,5
                      PDDIF(K) = PDDIF(K) + PDPE(K,IPE)*WTF
  240             CONTINUE
                  SMWTF = SMWTF + WTF
              ELSE
                  WTI = PWT(IPE)
                  DO 250 K = 1,5
                      PDDII(K) = PDDII(K) + PDPE(K,IPE)*WTI
  250             CONTINUE
                  SMWTI = SMWTI + WTI
              END IF
  260     CONTINUE
          IF (SMWTI.LE.0.0) THEN
              DO 270 K = 1,5
                  PDD(K,IDP1) = PDDIF(K)/SMWTF
  270         CONTINUE
          ELSE
              DO 280 K = 1,5
                  PDD(K,IDP1) = PDDII(K)/SMWTI
  280         CONTINUE
          END IF
          GO TO 310
* Only one qualified point set
  290     DO 300 K = 1,5
              PDD(K,IDP1) = PDPE(K,1)
  300     CONTINUE
  310 CONTINUE
      RETURN
      END


      SUBROUTINE SDCLDP(NDP,XD,YD, IPC, DSQ,IDSQ)
*
* Closest data points
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine selects, at each of the data points, nine data
* points closest to it.
*
* The input arguments are
*   NDP  = number of data points,
*   XD   = array of dimension NDP containing the x
*          coordinates of the data points,
*   YD   = array of dimension NDP containing the y
*          coordinates of the data points.
*
* The output argument is
*   IPC  = two-dimensional integer array of dimension 9*NDP,
*          where the point numbers of nine data points closest
*          to the IDPth data point, in an ascending order of
*          the distance from the IDPth point, are to be
*          stored in the IDPth column, where IDP = 1, 2,
*          ..., NDP.
*
* The other arguments are
*   DSQ  = array of dimension NDP used as a work area,
*   IDSQ = integer array of dimension NDP used as a work
*          area.
*
*
* Specification statements
*     .. Scalar Arguments ..
      INTEGER          NDP
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             DSQ(NDP),XD(NDP),YD(NDP)
      INTEGER          IDSQ(NDP),IPC(9,NDP)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION             DSQMN
      INTEGER          IDP,IDSQMN,JDP,JDPMN,JDSQMN,JIPC,JIPCMX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     ..
* DO-loop with respect to the data point number
      DO 50 IDP = 1,NDP
* Calculates the distance squared for all data points from the
* IDPth data point and stores the data point number and the
* calculated results in the IDSQ and DSQ arrays, respectively.
          DO 10 JDP = 1,NDP
              IDSQ(JDP) = JDP
              DSQ(JDP) = (XD(JDP)-XD(IDP))**2 + (YD(JDP)-YD(IDP))**2
   10     CONTINUE
* Sorts the IDSQ and DSQ arrays in such a way that the IDPth
* point is in the first element in each array.
          IDSQ(IDP) = 1
          DSQ(IDP) = DSQ(1)
          IDSQ(1) = IDP
          DSQ(1) = 0.0
* Selects nine data points closest to the IDPth data point and
* stores the data point numbers in the IPC array.
          JIPCMX = MIN(NDP-1,10)
          DO 30 JIPC = 2,JIPCMX
              JDSQMN = JIPC
              DSQMN = DSQ(JIPC)
              JDPMN = JIPC + 1
              DO 20 JDP = JDPMN,NDP
                  IF (DSQ(JDP).LT.DSQMN) THEN
                      JDSQMN = JDP
                      DSQMN = DSQ(JDP)
                  END IF
   20         CONTINUE
              IDSQMN = IDSQ(JDSQMN)
              IDSQ(JDSQMN) = IDSQ(JIPC)
              DSQ(JDSQMN) = DSQ(JIPC)
              IDSQ(JIPC) = IDSQMN
   30     CONTINUE
          DO 40 JIPC = 1,9
              IPC(JIPC,IDP) = IDSQ(JIPC+1)
   40     CONTINUE
   50 CONTINUE
      RETURN
      END


      SUBROUTINE SDCF3P(NDP,XD,YD,ZD,IPC, CF,NCP)
*
* Coefficients of the third-degree polynomial for z(x,y)
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine calculates, for each data point, coefficients
* of the third-degree polynomial for z(x,y) fitted to the set of
* 10 data points consisting of the data point in question and
* nine data points closest to it.  When the condition number of
* the matrix associated with the 10 data point set is too large,
* this subroutine calculates coefficients of the second-degree
* polynomial fitted to the set of six data points consisting of
* the data point in question and five data points closest to it.
* When the condition number of the matrix associated with the six
* data point set is too large, this subroutine calculates
* coefficients of the first-degree polynomial fitted to the set of
* three data points closest to the data point in question.  When
* the condition number of the matrix associated with the three data
* point set is too large, this subroutine calculates coefficients
* of the first-degree polynomial fitted to the set of two data
* points consisting of the data point in question and one data
* point closest to it, assuming that the plane represented by the
* polynomial is horizontal in the direction which is at right
* angles to the line connecting the two data points.
*
* The input arguments are
*   NDP = number of data points,
*   XD  = array of dimension NDP containing the x
*         coordinates of the data points,
*   YD  = array of dimension NDP containing the y
*         coordinates of the data points,
*   ZD  = array of dimension NDP containing the z values
*         at the data points,
*   IPC = two-dimensional integer array of dimension
*         9*NDP containing the point numbers of 9 data
*         points closest to the IDPth data point in the
*         IDPth column, where IDP = 1, 2, ..., NDP.
*
* The output arguments are
*   CF  = two-dimensional array of dimension 9*NDP,
*         where the coefficients of the polynomial
*         (a10, a20, a30, a01, a11, a21, a02, a12, a03)
*         calculated at the IDPth data point are to be
*         stored in the IDPth column, where IDP = 1, 2,
*         ..., NDP,
*   NCP = integer array of dimension NDP, where the numbers
*         of the closest points used are to be stored.
*
* The constant in the first PARAMETER statement below is
*   CNRMX = maximum value of the ratio of the condition
*           number of the matrix associated with the point
*           set to the number of points.
* The constant value has been selected empirically.
*
* The N1, N2, and N3 constants in the second PARAMETER statement
* are the numbers of the data points used to determine the first-,
* second-, and third-degree polynomials, respectively.
*
* This subroutine calls the SDLEQN subroutine.
*
*
* Specification statements
*     .. Parameters ..
      DOUBLE PRECISION             CNRMX
      PARAMETER        (CNRMX=1.5E+04)
      INTEGER          N1,N2,N3
      PARAMETER        (N1=3,N2=6,N3=10)
*     ..
*     .. Scalar Arguments ..
      INTEGER          NDP
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             CF(9,NDP),XD(NDP),YD(NDP),ZD(NDP)
      INTEGER          IPC(9,NDP),NCP(NDP)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION             CN,DET,X,X1,X2,Y,Y1,Y2,Z1,Z2
      INTEGER          I,IDP,IDPI,J
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION             AA1(N1,N1),AA2(N2,N2),AA3(N3,N3),
     +                 B(N3),CFI(N3),EE(N3,N3),ZZ(N3,N3)
      INTEGER          K(N3)
*     ..
*     .. External Subroutines ..
      EXTERNAL         SDLEQN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        DBLE
*     ..
* Main DO-loop with respect to the data point
      DO 60 IDP = 1,NDP
          DO 10 J = 1,9
              CF(J,IDP) = 0.0
   10     CONTINUE
* Calculates the coefficients of the set of linear equations
* with the 10-point data point set.
          DO 20 I = 1,N3
              IF (I.EQ.1) THEN
                  IDPI = IDP
              ELSE
                  IDPI = IPC(I-1,IDP)
              END IF
              X = XD(IDPI)
              Y = YD(IDPI)
              AA3(I,1) = 1.0
              AA3(I,2) = X
              AA3(I,3) = X*X
              AA3(I,4) = X*X*X
              AA3(I,5) = Y
              AA3(I,6) = X*Y
              AA3(I,7) = X*X*Y
              AA3(I,8) = Y*Y
              AA3(I,9) = X*Y*Y
              AA3(I,10) = Y*Y*Y
              B(I) = ZD(IDPI)
   20     CONTINUE
* Solves the set of linear equations.
          CALL SDLEQN(N3,AA3,B, CFI,DET,CN, K,EE,ZZ)
* Stores the calculated results as the coefficients of the
* third-degree polynomial when applicable.
          IF (DET.NE.0.0) THEN
              IF (CN.LE.CNRMX*DBLE(N3)) THEN
                  DO 30 J = 2,N3
                      CF(J-1,IDP) = CFI(J)
   30             CONTINUE
                  NCP(IDP) = N3 - 1
                  GO TO 60
              END IF
          END IF
* Calculates the coefficients of the set of linear equations
* with the 6-point data point set.
          DO 40 I = 1,N2
              IF (I.EQ.1) THEN
                  IDPI = IDP
              ELSE
                  IDPI = IPC(I-1,IDP)
              END IF
              X = XD(IDPI)
              Y = YD(IDPI)
              AA2(I,1) = 1.0
              AA2(I,2) = X
              AA2(I,3) = X*X
              AA2(I,4) = Y
              AA2(I,5) = X*Y
              AA2(I,6) = Y*Y
              B(I) = ZD(IDPI)
   40     CONTINUE
* Solves the set of linear equations.
          CALL SDLEQN(N2,AA2,B, CFI,DET,CN, K,EE,ZZ)
* Stores the calculated results as the coefficients of the
* second-degree polynomial when applicable.
          IF (DET.NE.0.0) THEN
              IF (CN.LE.CNRMX*DBLE(N2)) THEN
                  CF(1,IDP) = CFI(2)
                  CF(2,IDP) = CFI(3)
                  CF(4,IDP) = CFI(4)
                  CF(5,IDP) = CFI(5)
                  CF(7,IDP) = CFI(6)
                  NCP(IDP) = N2 - 1
                  GO TO 60
              END IF
          END IF
* Calculates the coefficients of the set of linear equations
* with the 3-point data point set.
          DO 50 I = 1,N1
              IDPI = IPC(I,IDP)
              X = XD(IDPI)
              Y = YD(IDPI)
              AA1(I,1) = 1.0
              AA1(I,2) = X
              AA1(I,3) = Y
              B(I) = ZD(IDPI)
   50     CONTINUE
* Solves the set of linear equations.
          CALL SDLEQN(N1,AA1,B, CFI,DET,CN, K,EE,ZZ)
* Stores the calculated results as the coefficients of the
* first-degree polynomial when applicable.
          IF (DET.NE.0.0) THEN
              IF (CN.LE.CNRMX*DBLE(N1)) THEN
                  CF(1,IDP) = CFI(2)
                  CF(4,IDP) = CFI(3)
                  NCP(IDP) = N1
                  GO TO 60
              END IF
          END IF
* Calculates the coefficients of the set of linear equations
* with the 2-point data point set when applicable.
          IDPI = IDP
          X1 = XD(IDPI)
          Y1 = YD(IDPI)
          Z1 = ZD(IDPI)
          IDPI = IPC(1,IDP)
          X2 = XD(IDPI)
          Y2 = YD(IDPI)
          Z2 = ZD(IDPI)
          CF(1,IDP) = (X2-X1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2)
          CF(4,IDP) = (Y2-Y1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2)
          NCP(IDP) = 1
   60 CONTINUE
      RETURN
      END


      SUBROUTINE SDLEQN(N,AA,B, X,DET,CN, K,EE,ZZ)
*
* Solution of a set of linear equations
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine solves a set of linear equations.
*
* The input arguments are
*   N   = number of linear equations,
*   AA  = two-dimensional array of dimension N*N
*         containing the coefficients of the equations,
*   B   = array of dimension N containing the constant
*         values in the right-hand side of the equations.
*
* The output arguments are
*   X   = array of dimension N, where the solution is
*         to be stored,
*   DET = determinant of the AA array,
*   CN  = condition number of the AA matrix.
*
* The other arguments are
*   K   = integer array of dimension N used internally
*         as the work area,
*   EE  = two-dimensional array of dimension N*N used
*         internally as the work area,
*   ZZ  = two-dimensional array of dimension N*N used
*         internally as the work area.
*
*
* Specification statements
*     .. Scalar Arguments ..
      DOUBLE PRECISION             CN,DET
      INTEGER          N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             AA(N,N),B(N),EE(N,N),X(N),ZZ(N,N)
      INTEGER          K(N)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION             AAIIJ,AAIJIJ,AAIJMX,AAMX,SA,SZ
      INTEGER          I,IJ,IJP1,IJR,J,JJ,JMX,KJMX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        ABS,SQRT
*     ..
* Calculation
* Initial setting
      DO 10 J = 1,N
          K(J) = J
   10 CONTINUE
      DO 30 I = 1,N
          DO 20 J = 1,N
              EE(I,J) = 0.0
   20     CONTINUE
          EE(I,I) = 1.0
   30 CONTINUE
* Calculation of inverse matrix of AA
      DO 110 IJ = 1,N
* Finds out the element having the maximum absolute value in the
* IJ th row.
          AAMX = ABS(AA(IJ,IJ))
          JMX = IJ
          DO 40 J = IJ,N
              IF (ABS(AA(IJ,J)).GT.AAMX) THEN
                  AAMX = ABS(AA(IJ,J))
                  JMX = J
              END IF
   40     CONTINUE
* Switches two columns in such a way that the element with the
* maximum value is on the diagonal.
          DO 50 I = 1,N
              AAIJMX = AA(I,IJ)
              AA(I,IJ) = AA(I,JMX)
              AA(I,JMX) = AAIJMX
   50     CONTINUE
          KJMX = K(IJ)
          K(IJ) = K(JMX)
          K(JMX) = KJMX
* Makes the diagonal element to be unity.
          AAIJIJ = AA(IJ,IJ)
          IF (AAIJIJ.EQ.0.0) GO TO 210
          DO 60 J = IJ,N
              AA(IJ,J) = AA(IJ,J)/AAIJIJ
   60     CONTINUE
          DO 70 JJ = 1,N
              EE(IJ,JJ) = EE(IJ,JJ)/AAIJIJ
   70     CONTINUE
* Eliminates the lower left elements.
          IF (IJ.LT.N) THEN
              IJP1 = IJ + 1
              DO 100 I = IJP1,N
                  AAIIJ = AA(I,IJ)
                  DO 80 J = IJP1,N
                      AA(I,J) = AA(I,J) - AA(IJ,J)*AAIIJ
   80             CONTINUE
                  DO 90 JJ = 1,N
                      EE(I,JJ) = EE(I,JJ) - EE(IJ,JJ)*AAIIJ
   90             CONTINUE
  100         CONTINUE
          END IF
* Calculates the determinant.
          IF (IJ.EQ.1) THEN
              DET = 1.0
          END IF
          DET = DET*AAIJIJ* ((-1)** (IJ+JMX))
  110 CONTINUE
* Calculates the elements of the inverse matrix.
      DO 140 IJR = 1,N
          IJ = N + 1 - IJR
          IF (IJ.LT.N) THEN
              IJP1 = IJ + 1
              DO 130 J = IJP1,N
                  DO 120 JJ = 1,N
                      EE(IJ,JJ) = EE(IJ,JJ) - AA(IJ,J)*EE(J,JJ)
  120             CONTINUE
  130         CONTINUE
          END IF
  140 CONTINUE
      DO 160 J = 1,N
          I = K(J)
          DO 150 JJ = 1,N
              ZZ(I,JJ) = EE(J,JJ)
  150     CONTINUE
  160 CONTINUE
* Calculation of the condition number of AA
      SA = 0.0
      SZ = 0.0
      DO 180 I = 1,N
          DO 170 J = 1,N
              SA = SA + AA(I,J)*AA(J,I)
              SZ = SZ + ZZ(I,J)*ZZ(J,I)
  170     CONTINUE
  180 CONTINUE
      CN = SQRT(ABS(SA*SZ))
* Calculation of X vector
      DO 200 I = 1,N
          X(I) = 0.0
          DO 190 J = 1,N
              X(I) = X(I) + ZZ(I,J)*B(J)
  190     CONTINUE
  200 CONTINUE
      RETURN
* Special case where the determinant is zero
  210 DO 220 I = 1,N
          X(I) = 0.0
  220 CONTINUE
      DET = 0.0
      RETURN
      END


      SUBROUTINE SDLS1P(NDP,XD,YD,ZD,IPC,NCP, CFL1)
*
* Least squares fit of a linear surface (plane) to z(x,y) values
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine performs the least squares fit of a linear
* surface (plane) to a data point set consisting of the data
* point in question and several data points closest to it used
* in the SDCF3P subroutine.
*
* The input arguments are
*   NDP  = number of data points,
*   XD   = array of dimension NDP containing the x coordinates
*          of the data points,
*   YD   = array of dimension NDP containing the y coordinates
*          of the data points,
*   ZD   = array of dimension NDP containing the z values at
*          the data points,
*   IPC  = two-dimensional integer array of dimension 9*NDP
*          containing, in the IDPth column, point numbers of
*          nine data points closest to the IDPth data point,
*          where IDP = 1, 2, ..., NDP,
*   NCP  = integer array of dimension NDP containing the
*          numbers of the closest points used in the SDCF3P
*          subroutine.
*
* The output argument is
*   CFL1 = two-dimensional array of dimension 2*NDP, where
*          the coefficients (a10, a01) of the least squares
*          fit, first-degree polynomial calculated at the
*          IDPth data point are to be stored in the IDPth
*          column, where IDP = 1, 2, ..., NDP.
*
* Before this subroutine is called, the SDCF3P subroutine must
* have been called.
*
*
* Specification statements
*     .. Scalar Arguments ..
      INTEGER          NDP
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             CFL1(2,NDP),XD(NDP),YD(NDP),ZD(NDP)
      INTEGER          IPC(9,NDP),NCP(NDP)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION             A11,A12,A22,AN,B1,B2,DLT,SX,SXX,SXY,
     +                 SXZ,SY,SYY,SYZ,SZ,X,X1,X2,Y,Y1,Y2,Z,Z1,Z2
      INTEGER          I,IDP,IDPI,NPLS
*     ..
* DO-loop with respect to the data point
      DO 30 IDP = 1,NDP
          NPLS = NCP(IDP) + 1
          IF (NPLS.EQ.2) GO TO 20
* Performs the least squares fit of a plane.
          SX = 0.0
          SY = 0.0
          SXX = 0.0
          SXY = 0.0
          SYY = 0.0
          SZ = 0.0
          SXZ = 0.0
          SYZ = 0.0
          DO 10 I = 1,NPLS
              IF (I.EQ.1) THEN
                  IDPI = IDP
              ELSE
                  IDPI = IPC(I-1,IDP)
              END IF
              X = XD(IDPI)
              Y = YD(IDPI)
              Z = ZD(IDPI)
              SX = SX + X
              SY = SY + Y
              SXX = SXX + X*X
              SXY = SXY + X*Y
              SYY = SYY + Y*Y
              SZ = SZ + Z
              SXZ = SXZ + X*Z
              SYZ = SYZ + Y*Z
   10     CONTINUE
          AN = NPLS
          A11 = AN*SXX - SX*SX
          A12 = AN*SXY - SX*SY
          A22 = AN*SYY - SY*SY
          B1 = AN*SXZ - SX*SZ
          B2 = AN*SYZ - SY*SZ
          DLT = A11*A22 - A12*A12
          CFL1(1,IDP) = (B1*A22-B2*A12)/DLT
          CFL1(2,IDP) = (B2*A11-B1*A12)/DLT
          GO TO 30
   20     IDPI = IDP
          X1 = XD(IDPI)
          Y1 = YD(IDPI)
          Z1 = ZD(IDPI)
          IDPI = IPC(1,IDP)
          X2 = XD(IDPI)
          Y2 = YD(IDPI)
          Z2 = ZD(IDPI)
          CFL1(1,IDP) = (X2-X1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2)
          CFL1(2,IDP) = (Y2-Y1)* (Z2-Z1)/ ((X2-X1)**2+ (Y2-Y1)**2)
   30 CONTINUE
      RETURN
      END


      SUBROUTINE SDLCTN(NDP,XD,YD,NT,IPT,NL,IPL,NIP,XI,YI, KTLI,ITLI)
*
* Locating points in a scattered data point set
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine locates points in a scattered data point set in
* the x-y plane, i.e., determines to which triangle each of the
* points to be located belongs.  When a point to be located does
* not lie inside the data area, this subroutine determines the
* border line segment when the point lies in an outside rectangle,
* in an outside triangle, or in the overlap of two outside
* rectangles.
*
* The input arguments are
*   NDP  = number of data points,
*   XD   = array of dimension NDP containing the x
*          coordinates of the data points,
*   YD   = array of dimension NDP containing the y
*          coordinates of the data points,
*   NT   = number of triangles,
*   IPT  = two-dimensional integer array of dimension 3*NT
*          containing the point numbers of the vertexes of
*          the triangles,
*   NL   = number of border line segments,
*   IPL  = two-dimensional integer array of dimension 2*NL
*          containing the point numbers of the end points of
*          the border line segments,
*   NIP  = number of points to be located,
*   XI   = array of dimension NIP containing the x
*          coordinates of the points to be located,
*   YI   = array of dimension NIP containing the y
*          coordinates of the points to be located.
*
* The output arguments are
*   KTLI = integer array of dimension NIP, where the code
*          for the type of the piece of plane in which each
*          interpolated point lies is to be stored
*        = 1 for a triangle inside the data area
*        = 2 for a rectangle on the right-hand side of a
*            border line segment
*        = 3 for a triangle between two rectangles on the
*            right-hand side of two consecutive border line
*            segments
*        = 4 for a triangle which is an overlap of two
*            rectangles on the right-hand side of two
*            consecutive border line segments,
*   ITLI = integer array of dimension NIP, where the
*          triangle numbers or the (second) border line
*          segment numbers corresponding to the points to
*          be located are to be stored.
*
*
* Specification statements
*     .. Scalar Arguments ..
      INTEGER          NDP,NIP,NL,NT
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             XD(NDP),XI(NIP),YD(NDP),YI(NIP)
      INTEGER          IPL(2,NL),IPT(3,NT),ITLI(NIP),KTLI(NIP)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION             U1,U2,U3,V1,V2,V3,X0,X1,X2,X3,Y0,Y1,
     +                             Y2,Y3
      INTEGER          IIP,IL1,IL2,ILII,IP1,IP2,IP3,ITII,ITLIPV,KTLIPV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        MOD
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION             SPDT,VPDT
*     ..
* Statement Function definitions
      SPDT(U1,V1,U2,V2,U3,V3) = (U1-U3)* (U2-U3) + (V1-V3)* (V2-V3)
      VPDT(U1,V1,U2,V2,U3,V3) = (U1-U3)* (V2-V3) - (V1-V3)* (U2-U3)
*     ..
* Outermost DO-loop with respect to the points to be located
      DO 40 IIP = 1,NIP
          X0 = XI(IIP)
          Y0 = YI(IIP)
          IF (IIP.EQ.1) THEN
              KTLIPV = 0
              ITLIPV = 0
          ELSE
              KTLIPV = KTLI(IIP-1)
              ITLIPV = ITLI(IIP-1)
          END IF
* Checks if in the same inside triangle as previous.
          IF (KTLIPV.EQ.1) THEN
              ITII = ITLIPV
              IP1 = IPT(1,ITII)
              IP2 = IPT(2,ITII)
              IP3 = IPT(3,ITII)
              X1 = XD(IP1)
              Y1 = YD(IP1)
              X2 = XD(IP2)
              Y2 = YD(IP2)
              X3 = XD(IP3)
              Y3 = YD(IP3)
              IF ((VPDT(X1,Y1,X2,Y2,X0,Y0).GE.0.0) .AND.
     +            (VPDT(X2,Y2,X3,Y3,X0,Y0).GE.0.0) .AND.
     +            (VPDT(X3,Y3,X1,Y1,X0,Y0).GE.0.0)) THEN
                  KTLI(IIP) = 1
                  ITLI(IIP) = ITII
                  GO TO 40
              END IF
          END IF
* Locates inside the data area.
          DO 10 ITII = 1,NT
              IP1 = IPT(1,ITII)
              IP2 = IPT(2,ITII)
              IP3 = IPT(3,ITII)
              X1 = XD(IP1)
              Y1 = YD(IP1)
              X2 = XD(IP2)
              Y2 = YD(IP2)
              X3 = XD(IP3)
              Y3 = YD(IP3)
              IF ((VPDT(X1,Y1,X2,Y2,X0,Y0).GE.0.0) .AND.
     +            (VPDT(X2,Y2,X3,Y3,X0,Y0).GE.0.0) .AND.
     +            (VPDT(X3,Y3,X1,Y1,X0,Y0).GE.0.0)) THEN
                  KTLI(IIP) = 1
                  ITLI(IIP) = ITII
                  GO TO 40
              END IF
   10     CONTINUE
* Locates outside the data area.
          DO 20 ILII = 1,NL
              IL1 = ILII
              IL2 = MOD(IL1,NL) + 1
              IP1 = IPL(1,IL1)
              IP2 = IPL(1,IL2)
              IP3 = IPL(2,IL2)
              X1 = XD(IP1)
              Y1 = YD(IP1)
              X2 = XD(IP2)
              Y2 = YD(IP2)
              X3 = XD(IP3)
              Y3 = YD(IP3)
              IF (VPDT(X1,Y1,X3,Y3,X0,Y0).LE.0.0) THEN
                  IF (VPDT(X1,Y1,X3,Y3,X2,Y2).LE.0.0) THEN
                      IF ((SPDT(X1,Y1,X0,Y0,X2,Y2).LE.0.0) .AND.
     +                    (SPDT(X3,Y3,X0,Y0,X2,Y2).LE.0.0)) THEN
                          KTLI(IIP) = 3
                          ITLI(IIP) = IL2
                          GO TO 40
                      END IF
                  END IF
                  IF (VPDT(X1,Y1,X3,Y3,X2,Y2).GE.0.0) THEN
                      IF ((SPDT(X1,Y1,X0,Y0,X2,Y2).GE.0.0) .AND.
     +                    (SPDT(X3,Y3,X0,Y0,X2,Y2).GE.0.0)) THEN
                          KTLI(IIP) = 4
                          ITLI(IIP) = IL2
                          GO TO 40
                      END IF
                  END IF
              END IF
   20     CONTINUE
          DO 30 ILII = 1,NL
              IL2 = ILII
              IP2 = IPL(1,IL2)
              IP3 = IPL(2,IL2)
              X2 = XD(IP2)
              Y2 = YD(IP2)
              X3 = XD(IP3)
              Y3 = YD(IP3)
              IF (VPDT(X2,Y2,X3,Y3,X0,Y0).LE.0.0) THEN
                  IF ((SPDT(X3,Y3,X0,Y0,X2,Y2).GE.0.0) .AND.
     +                (SPDT(X2,Y2,X0,Y0,X3,Y3).GE.0.0)) THEN
                      KTLI(IIP) = 2
                      ITLI(IIP) = IL2
                      GO TO 40
                  END IF
              END IF
   30     CONTINUE
   40 CONTINUE
      END


      SUBROUTINE SDPLNL(NDP,XD,YD,ZD,NT,IPT,NL,IPL,PDD,NIP,XI,YI,KTLI,
     +                  ITLI, ZI, EXTRPI)
*
* Polynomials
* (a supporting subroutine of the SDBI3P/SDSF3P subroutine package)
*
* Hiroshi Akima
* U.S. Department of Commerce, NTIA/ITS
* Version of 1995/05
*
* This subroutine determines a polynomial in x and y for each
* triangle or rectangle in the x-y plane and calculates the z
* value by evaluating the polynomial for the desired points,
* for bivariate interpolation and surface fitting for scattered
* data.
*
* The input arguments are
*   NDP  = number of data points,
*   XD   = array of dimension NDP containing the x
*          coordinates of the data points,
*   YD   = array of dimension NDP containing the y
*          coordinates of the data points,
*   ZD   = array of dimension NDP containing the z
*          values at the data points,
*   NT   = number of triangles,
*   IPT  = two-dimensional integer array of dimension 3*NT
*          containing the point numbers of the vertexes of
*          the triangles,
*   NL   = number of border line segments,
*   IPL  = two-dimensional integer array of dimension 2*NL
*          containing the point numbers of the end points of
*          the border line segments,
*   PDD  = two-dimensional array of dimension 5*NDP
*          containing the partial derivatives at the data
*          points,
*   NIP  = number of output points at which interpolation is
*          to be performed,
*   XI   = array of dimension NIP containing the x
*          coordinates of the output points,
*   YI   = array of dimension NIP containing the y
*          coordinates of the output points,
*   KTLI = integer array of dimension NIP, each element
*          containing the code for the type of the piece of
*          the plane in which each output point lies
*        = 1 for a triangle inside the data area
*        = 2 for a rectangle on the right-hand side of a
*            border line segment
*        = 3 for a triangle between two rectangles on the
*            right-hand side of two consecutive border
*            line segments
*        = 4 for the triangle which is an overlap of two
*            rectangles on the right-hand side of two
*            consecutive border line segments,
*   ITLI = integer array of dimension NIP containing the
*          triangle numbers or the (second) border line
*          segment numbers corresponding to the output
*          points.
*
* The output argument is
*   ZI   = array of dimension NIP, where the calculated z
*          values are to be stored.
*   EXTRPI = logical array of dimension NIP, indicating
*            if a point resides outside the convex hull (and its Z value
*            has been extrapolated)
*
* Specification statements
*     .. Scalar Arguments ..
      INTEGER          NDP,NIP,NL,NT
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION             PDD(5,NDP),XD(NDP),XI(NIP),YD(NDP),
     +                 YI(NIP),ZD(NDP),ZI(NIP)
      INTEGER          IPL(2,NL),IPT(3,NT),ITLI(NIP),KTLI(NIP)
      LOGICAL          EXTRPI(NIP)
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION             A,AA,AB,ACT2,AD,ADBC,AP,B,BB,BC,BDT2,
     +                 BP,C,CC,CD,
     +                 CP,D,DD,DLT,DP,DX,DY,E1,E2,G1,G2,H1,H2,H3,LUSQ,
     +                 LVSQ,P0,P00,P01,P02,P03,P04,P05,P1,P10,P11,P12,
     +                 P13,P14,P2,P20,P21,P22,P23,P3,P30,P31,P32,P4,P40,
     +                 P41,P5,P50,SPUV,U,V,WT1,WT2,X0,XII,Y0,YII,Z0,ZII,
     +                 ZII1,ZII2
      INTEGER          I,IDP,IIP,ILI,IR,ITLII,ITLIPV,K,KTLII,KTLIPV
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION             PD(5,3),X(3),Y(3),Z(3),ZU(3),ZUU(3),
     +                 ZUV(3),ZV(3),ZVV(3)
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC        MOD
*     ..
* Outermost DO-loop with respect to the output point
      DO 120 IIP = 1,NIP
          XII = XI(IIP)
          YII = YI(IIP)
          KTLII = KTLI(IIP)
          ITLII = ITLI(IIP)
          IF (IIP.EQ.1) THEN
              KTLIPV = 0
              ITLIPV = 0
          ELSE
              KTLIPV = KTLI(IIP-1)
              ITLIPV = ITLI(IIP-1)
          END IF
* Part 1.  Calculation of ZII by interpolation
          IF (KTLII.EQ.1) THEN
* Calculates the coefficients when necessary.
              IF (KTLII.NE.KTLIPV .OR. ITLII.NE.ITLIPV) THEN
* Loads coordinate and partial derivative values at the
* vertexes.
                  DO 20 I = 1,3
                      IDP = IPT(I,ITLII)
                      X(I) = XD(IDP)
                      Y(I) = YD(IDP)
                      Z(I) = ZD(IDP)
                      DO 10 K = 1,5
                          PD(K,I) = PDD(K,IDP)
   10                 CONTINUE
   20             CONTINUE
* Determines the coefficients for the coordinate system
* transformation from the x-y system to the u-v system
* and vice versa.
                  X0 = X(1)
                  Y0 = Y(1)
                  A = X(2) - X0
                  B = X(3) - X0
                  C = Y(2) - Y0
                  D = Y(3) - Y0
                  AD = A*D
                  BC = B*C
                  DLT = AD - BC
                  AP = D/DLT
                  BP = -B/DLT
                  CP = -C/DLT
                  DP = A/DLT
* Converts the partial derivatives at the vertexes of the
* triangle for the u-v coordinate system.
                  AA = A*A
                  ACT2 = 2.0*A*C
                  CC = C*C
                  AB = A*B
                  ADBC = AD + BC
                  CD = C*D
                  BB = B*B
                  BDT2 = 2.0*B*D
                  DD = D*D
                  DO 30 I = 1,3
                      ZU(I) = A*PD(1,I) + C*PD(2,I)
                      ZV(I) = B*PD(1,I) + D*PD(2,I)
                      ZUU(I) = AA*PD(3,I) + ACT2*PD(4,I) + CC*PD(5,I)
                      ZUV(I) = AB*PD(3,I) + ADBC*PD(4,I) + CD*PD(5,I)
                      ZVV(I) = BB*PD(3,I) + BDT2*PD(4,I) + DD*PD(5,I)
   30             CONTINUE
* Calculates the coefficients of the polynomial.
                  P00 = Z(1)
                  P10 = ZU(1)
                  P01 = ZV(1)
                  P20 = 0.5*ZUU(1)
                  P11 = ZUV(1)
                  P02 = 0.5*ZVV(1)
                  H1 = Z(2) - P00 - P10 - P20
                  H2 = ZU(2) - P10 - ZUU(1)
                  H3 = ZUU(2) - ZUU(1)
                  P30 = 10.0*H1 - 4.0*H2 + 0.5*H3
                  P40 = -15.0*H1 + 7.0*H2 - H3
                  P50 = 6.0*H1 - 3.0*H2 + 0.5*H3
                  H1 = Z(3) - P00 - P01 - P02
                  H2 = ZV(3) - P01 - ZVV(1)
                  H3 = ZVV(3) - ZVV(1)
                  P03 = 10.0*H1 - 4.0*H2 + 0.5*H3
                  P04 = -15.0*H1 + 7.0*H2 - H3
                  P05 = 6.0*H1 - 3.0*H2 + 0.5*H3
                  LUSQ = AA + CC
                  LVSQ = BB + DD
                  SPUV = AB + CD
                  P41 = 5.0*SPUV/LUSQ*P50
                  P14 = 5.0*SPUV/LVSQ*P05
                  H1 = ZV(2) - P01 - P11 - P41
                  H2 = ZUV(2) - P11 - 4.0*P41
                  P21 = 3.0*H1 - H2
                  P31 = -2.0*H1 + H2
                  H1 = ZU(3) - P10 - P11 - P14
                  H2 = ZUV(3) - P11 - 4.0*P14
                  P12 = 3.0*H1 - H2
                  P13 = -2.0*H1 + H2
                  E1 = (LVSQ-SPUV)/ ((LVSQ-SPUV)+ (LUSQ-SPUV))
                  E2 = 1.0 - E1
                  G1 = 5.0*E1 - 2.0
                  G2 = 1.0 - G1
                  H1 = 5.0* (E1* (P50-P41)+E2* (P05-P14)) + (P41+P14)
                  H2 = 0.5*ZVV(2) - P02 - P12
                  H3 = 0.5*ZUU(3) - P20 - P21
                  P22 = H1 + G1*H2 + G2*H3
                  P32 = H2 - P22
                  P23 = H3 - P22
              END IF
* Converts XII and YII to u-v system.
              DX = XII - X0
              DY = YII - Y0
              U = AP*DX + BP*DY
              V = CP*DX + DP*DY
* Evaluates the polynomial.
              P0 = P00 + V* (P01+V* (P02+V* (P03+V* (P04+V*P05))))
              P1 = P10 + V* (P11+V* (P12+V* (P13+V*P14)))
              P2 = P20 + V* (P21+V* (P22+V*P23))
              P3 = P30 + V* (P31+V*P32)
              P4 = P40 + V*P41
              P5 = P50
              ZI(IIP) = P0 + U* (P1+U* (P2+U* (P3+U* (P4+U*P5))))
              EXTRPI(IIP) = .FALSE.
          END IF
* Part 2.  Calculation of ZII by extrapolation in the rectangle
          IF (KTLII.EQ.2) THEN
* Calculates the coefficients when necessary.
              IF (KTLII.NE.KTLIPV .OR. ITLII.NE.ITLIPV) THEN
* Loads coordinate and partial derivative values at the end
* points of the border line segment.
                  DO 50 I = 1,2
                      IDP = IPL(I,ITLII)
                      X(I) = XD(IDP)
                      Y(I) = YD(IDP)
                      Z(I) = ZD(IDP)
                      DO 40 K = 1,5
                          PD(K,I) = PDD(K,IDP)
   40                 CONTINUE
   50             CONTINUE
* Determines the coefficients for the coordinate system
* transformation from the x-y system to the u-v system
* and vice versa.
                  X0 = X(1)
                  Y0 = Y(1)
                  A = Y(2) - Y(1)
                  B = X(2) - X(1)
                  C = -B
                  D = A
                  AD = A*D
                  BC = B*C
                  DLT = AD - BC
                  AP = D/DLT
                  BP = -B/DLT
                  CP = -BP
                  DP = AP
* Converts the partial derivatives at the end points of the
* border line segment for the u-v coordinate system.
                  AA = A*A
                  ACT2 = 2.0*A*C
                  CC = C*C
                  AB = A*B
                  ADBC = AD + BC
                  CD = C*D
                  BB = B*B
                  BDT2 = 2.0*B*D
                  DD = D*D
                  DO 60 I = 1,2
                      ZU(I) = A*PD(1,I) + C*PD(2,I)
                      ZV(I) = B*PD(1,I) + D*PD(2,I)
                      ZUU(I) = AA*PD(3,I) + ACT2*PD(4,I) + CC*PD(5,I)
                      ZUV(I) = AB*PD(3,I) + ADBC*PD(4,I) + CD*PD(5,I)
                      ZVV(I) = BB*PD(3,I) + BDT2*PD(4,I) + DD*PD(5,I)
   60             CONTINUE
* Calculates the coefficients of the polynomial.
                  P00 = Z(1)
                  P10 = ZU(1)
                  P01 = ZV(1)
                  P20 = 0.5*ZUU(1)
                  P11 = ZUV(1)
                  P02 = 0.5*ZVV(1)
                  H1 = Z(2) - P00 - P01 - P02
                  H2 = ZV(2) - P01 - ZVV(1)
                  H3 = ZVV(2) - ZVV(1)
                  P03 = 10.0*H1 - 4.0*H2 + 0.5*H3
                  P04 = -15.0*H1 + 7.0*H2 - H3
                  P05 = 6.0*H1 - 3.0*H2 + 0.5*H3
                  H1 = ZU(2) - P10 - P11
                  H2 = ZUV(2) - P11
                  P12 = 3.0*H1 - H2
                  P13 = -2.0*H1 + H2
                  P21 = 0.5* (ZUU(2)-ZUU(1))
              END IF
* Converts XII and YII to u-v system.
              DX = XII - X0
              DY = YII - Y0
              U = AP*DX + BP*DY
              V = CP*DX + DP*DY
* Evaluates the polynomial.
              P0 = P00 + V* (P01+V* (P02+V* (P03+V* (P04+V*P05))))
              P1 = P10 + V* (P11+V* (P12+V*P13))
              P2 = P20 + V*P21
              ZI(IIP) = P0 + U* (P1+U*P2)
              EXTRPI(IIP) = .TRUE.
          END IF
* Part 3.  Calculation of ZII by extrapolation in the triangle
          IF (KTLII.EQ.3) THEN
* Calculates the coefficients when necessary.
              IF (KTLII.NE.KTLIPV .OR. ITLII.NE.ITLIPV) THEN
* Loads coordinate and partial derivative values at the vertex
* of the triangle.
                  IDP = IPL(1,ITLII)
                  X0 = XD(IDP)
                  Y0 = YD(IDP)
                  Z0 = ZD(IDP)
                  DO 70 K = 1,5
                      PD(K,1) = PDD(K,IDP)
   70             CONTINUE
* Calculates the coefficients of the polynomial.
                  P00 = Z0
                  P10 = PD(1,1)
                  P01 = PD(2,1)
                  P20 = 0.5*PD(3,1)
                  P11 = PD(4,1)
                  P02 = 0.5*PD(5,1)
              END IF
* Converts XII and YII to U-V system.
              U = XII - X0
              V = YII - Y0
* Evaluates the polynomial.
              P0 = P00 + V* (P01+V*P02)
              P1 = P10 + V*P11
              ZI(IIP) = P0 + U* (P1+U*P20)
              EXTRPI(IIP) = .TRUE.
          END IF
* Part 4.  Calculation of ZII by extrapolation in the triangle
*          which is an overlap of two rectangles.
          IF (KTLII.EQ.4) THEN
* Calculates the coefficients.
              DO 110 IR = 1,2
                  IF (IR.EQ.1) THEN
                      ILI = MOD(ITLII+NL-2,NL) + 1
                  ELSE
                      ILI = ITLII
                  END IF
* Loads coordinate and partial derivative values at the end
* points of the border line segment.
                  DO 90 I = 1,2
                      IDP = IPL(I,ILI)
                      X(I) = XD(IDP)
                      Y(I) = YD(IDP)
                      Z(I) = ZD(IDP)
                      DO 80 K = 1,5
                          PD(K,I) = PDD(K,IDP)
   80                 CONTINUE
   90             CONTINUE
* Determines the coefficients for the coordinate system
* transformation from the x-y system to the u-v system
* and vice versa.
                  X0 = X(1)
                  Y0 = Y(1)
                  A = Y(2) - Y(1)
                  B = X(2) - X(1)
                  C = -B
                  D = A
                  AD = A*D
                  BC = B*C
                  DLT = AD - BC
                  AP = D/DLT
                  BP = -B/DLT
                  CP = -BP
                  DP = AP
* Converts the partial derivatives at the end points of the
* border line segment for the u-v coordinate system.
                  AA = A*A
                  ACT2 = 2.0*A*C
                  CC = C*C
                  AB = A*B
                  ADBC = AD + BC
                  CD = C*D
                  BB = B*B
                  BDT2 = 2.0*B*D
                  DD = D*D
                  DO 100 I = 1,2
                      ZU(I) = A*PD(1,I) + C*PD(2,I)
                      ZV(I) = B*PD(1,I) + D*PD(2,I)
                      ZUU(I) = AA*PD(3,I) + ACT2*PD(4,I) + CC*PD(5,I)
                      ZUV(I) = AB*PD(3,I) + ADBC*PD(4,I) + CD*PD(5,I)
                      ZVV(I) = BB*PD(3,I) + BDT2*PD(4,I) + DD*PD(5,I)
  100             CONTINUE
* Calculates the coefficients of the polynomial.
                  P00 = Z(1)
                  P10 = ZU(1)
                  P01 = ZV(1)
                  P20 = 0.5*ZUU(1)
                  P11 = ZUV(1)
                  P02 = 0.5*ZVV(1)
                  H1 = Z(2) - P00 - P01 - P02
                  H2 = ZV(2) - P01 - ZVV(1)
                  H3 = ZVV(2) - ZVV(1)
                  P03 = 10.0*H1 - 4.0*H2 + 0.5*H3
                  P04 = -15.0*H1 + 7.0*H2 - H3
                  P05 = 6.0*H1 - 3.0*H2 + 0.5*H3
                  H1 = ZU(2) - P10 - P11
                  H2 = ZUV(2) - P11
                  P12 = 3.0*H1 - H2
                  P13 = -2.0*H1 + H2
                  P21 = 0.5* (ZUU(2)-ZUU(1))
* Converts XII and YII to u-v system.
                  DX = XII - X0
                  DY = YII - Y0
                  U = AP*DX + BP*DY
                  V = CP*DX + DP*DY
* Evaluates the polynomial.
                  P0 = P00 + V* (P01+V* (P02+V* (P03+V* (P04+V*P05))))
                  P1 = P10 + V* (P11+V* (P12+V*P13))
                  P2 = P20 + V*P21
                  ZII = P0 + U* (P1+U*P2)
                  IF (IR.EQ.1) THEN
                      ZII1 = ZII
                      WT2 = ((X(1)-X(2))* (XII-X(2))+
     +                      (Y(1)-Y(2))* (YII-Y(2)))**2
                  ELSE
                      ZII2 = ZII
                      WT1 = ((X(2)-X(1))* (XII-X(1))+
     +                      (Y(2)-Y(1))* (YII-Y(1)))**2
                  END IF
  110         CONTINUE
              ZI(IIP) = (WT1*ZII1+WT2*ZII2)/ (WT1+WT2)
              EXTRPI(IIP) = .TRUE.
          END IF
  120 CONTINUE
      END

      DOUBLE PRECISION FUNCTION C06DBF(X,C,N,S)
C     MARK 6 RELEASE. NAG COPYRIGHT 1977.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     THIS FUNCTION EVALUATES A CHEBYSHEV SERIES OF ONE OF THREE
C     FORMS ACCORDING TO THE VALUE OF S
C     S=1- 0.5*C(1)+SUM FROM J=2 TO N OF C(J)*T(J-1)(X),
C     S=2- 0.5*C(1)+SUM FROM J=2 TO N OF C(J)*T(2J-2)(X),
C     S=3- SUM FROM J=1 TO N OF C(J)*T(2J-1)(X),
C     WHERE X LIES IN THE RANGE -1.0 .LE. X .LE. 1.0
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION                 X
      INTEGER                          N, S
C     .. Array Arguments ..
      DOUBLE PRECISION                 C(N)
C     .. Local Scalars ..
      DOUBLE PRECISION                 A, B, D, Y, Y2
      INTEGER                          R
C     .. Executable Statements ..
      IF (S.EQ.1) GO TO 20
      Y = 2.0D0*X*X - 1.0D0
      GO TO 40
   20 Y = X
   40 Y2 = 2.0D0*Y
      A = 0.0D0
      B = 0.0D0
      R = N
      D = C(R)
      IF (R.EQ.1) GO TO 80
   60 R = R - 1
      A = B
      B = D
      D = C(R) - A + Y2*B
      IF (R.GT.1) GO TO 60
   80 IF (S.EQ.3) GO TO 100
      C06DBF = 0.5D0*(D-A)
      GO TO 120
  100 C06DBF = X*(D-B)
  120 RETURN
      END

      SUBROUTINE E01AEF(M,XMIN,XMAX,X,Y,IP,N,ITMIN,ITMAX,A,WRK,LWRK,
     *                  IWRK,LIWRK,IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     *******************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE PINTRP
C
C     CREATED 17 07 79.  UPDATED 14 05 80.  RELEASE 00/42
C
C     AUTHORS ... GERALD T. ANTHONY, MAURICE G. COX,
C                 J. GEOFFREY HAYES AND MICHAEL A. SINGER.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND
C
C     *******************************************************
C
C     E01AEF. A ROUTINE, WITH CHECKS, WHICH DETERMINES AND
C     REFINES A POLYNOMIAL INTERPOLANT  Q(X)  TO DATA WHICH
C     MAY CONTAIN DERIVATIVES.
C
C     INPUT PARAMETERS
C        M        NUMBER OF DISTINCT X-VALUES
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C        X        INDEPENDENT VARIABLE VALUES (DISTINCT)
C        Y        VALUES AND DERIVATIVES OF
C                    DEPENDENT VARIABLE.
C        IP       HIGHEST ORDER OF DERIVATIVE AT EACH X-VALUE.
C        N        NUMBER OF INTERPOLATING CONDITIONS.
C                    N = M + IP(1) + IP(2) + ... + IP(M).
C        ITMIN,
C        ITMAX    MINIMUM AND MAXIMUM NUMBER OF ITERATIONS TO BE
C                    PERFORMED.
C
C     OUTPUT PARAMETERS
C        A        CHEBYSHEV COEFFICIENTS OF  Q(X)
C
C     WORKSPACE (AND ASSOCIATED DIMENSION) PARAMETERS
C        WRK      REAL WORKSPACE ARRAY.  THE FIRST IMAX ELEMENTS
C                    CONTAIN, ON EXIT, PERFORMANCE INDICES FOR
C                    THE INTERPOLATING POLYNOMIAL, AND THE NEXT
C                    N  ELEMENTS THE COMPUTED RESIDUALS
C        LWRK     DIMENSION OF WRK. LWRK MUST BE AT LEAST
C                    7*N + 5*IMAX + M + 2, WHERE
C                    IMAX IS ONE MORE THAN THE LARGEST ELEMENT
C                    OF THE ARRAY IP.
C        IWRK     INTEGER WORKSPACE ARRAY.  ON EXIT,  IWRK(1)
C                    CONTAINS THE NUMBER OF ITERATIONS TAKEN
C        LIWRK    DIMENSION OF IWRK.  AT LEAST 2*M + 2.
C
C     FAILURE INDICATOR PARAMETER
C        IFAIL    FAILURE INDICATOR.
C                    0 - SUCCESSFUL TERMINATION.
C                    1 - AT LEAST ONE OF THE FOLLOWING CONDITIONS
C                        HAS BEEN VIOLATED -
C                           M AT LEAST 1,
C                           N = M + IP(1) + IP(2) + ... + IP(M),
C                           LWRK AT LEAST 7*N + 5*IMAX + M + 2,
C                           LIWRK AT LEAST 2*M + 2.
C                    2 - FOR SOME I, IP(I) IS LESS THAN 0.
C                    3 - AT LEAST ONE OF THE FOLLOWING CONDITIONS
C                        HAS BEEN VIOLATED -
C                           XMIN STRICTLY LESS THAN XMAX,
C                           FOR EACH I, X(I) MUST LIE IN THE
C                              INTERVAL XMIN TO XMAX,
C                           THE X-VALUES MUST ALL BE DISTINCT
C                    4 - NOT ALL PERFORMANCE INDICES LESS THAN
C                        ONE, BUT ITMAX ITERATIONS PERFORMED,
C                    5 - COMPUTATION TERMINATED BECAUSE
C                        ITERATIONS DIVERGING.
C
C
C     CHECK AND SET ITERATION LIMITS
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E01AEF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           IFAIL, ITMAX, ITMIN, LIWRK, LWRK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(N), WRK(LWRK), X(M), Y(N)
      INTEGER           IP(M), IWRK(LIWRK)
C     .. Local Scalars ..
      DOUBLE PRECISION  XI
      INTEGER           I, IERROR, IMAX, IP1, ITMAX1, ITMIN1, J, NN
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          E01AEW
C     .. Executable Statements ..
      ITMIN1 = ITMIN
      ITMAX1 = ITMAX
      IF (ITMIN1.LE.0) ITMIN1 = 2
      IF (ITMAX1.LE.0) ITMAX1 = 10
      IF (ITMAX1.LT.ITMIN1) ITMAX1 = ITMIN1
C
C     FIRST SET OF CHECKS ON INPUT DATA
C
      IERROR = 1
C
      IF (M.LT.1) GO TO 100
C
C     DETERMINE  IMAX = MAX(IP(I) + 1),  AND  NN = SUM
C     OF VALUES OF  (IP(I) + 1)  FOR COMPARISON WITH  N
C
      IMAX = 0
      NN = M
      DO 20 I = 1, M
         IF (IP(I).GT.IMAX) IMAX = IP(I)
         NN = NN + IP(I)
   20 CONTINUE
      IMAX = IMAX + 1
C
C     REMAINDER OF FIRST SET OF INPUT DATA CHECKS
C
      IF (NN.NE.N) GO TO 100
      IF (LWRK.LT.7*N+5*IMAX+M+2) GO TO 100
      IF (LIWRK.LT.2*M+2) GO TO 100
C
C     SECOND SET OF CHECKS ON INPUT DATA
C
      IERROR = 2
      DO 40 I = 1, M
         IF (IP(I).LT.0) GO TO 100
   40 CONTINUE
C
C     THIRD SET OF CHECKS ON INPUT DATA
C
      IERROR = 3
      IF (XMIN.GE.XMAX) GO TO 100
      DO 80 I = 1, M
         XI = X(I)
         IF (XI.LT.XMIN .OR. XI.GT.XMAX) GO TO 100
         IF (I.EQ.M) GO TO 80
         IP1 = I + 1
         DO 60 J = IP1, M
            IF (XI.EQ.X(J)) GO TO 100
   60    CONTINUE
   80 CONTINUE
C
C     END OF CHECKS ON INPUT DATA
C
      IERROR = 0
C
C     INDICATE THAT ZEROIZING POLYNOMIAL  Q0(X)  IS
C     NOT REQUIRED
C
      IWRK(1) = 0
      CALL E01AEW(M,XMIN,XMAX,X,Y,IP,N,N+1,ITMIN1,ITMAX1,A,WRK,WRK,LWRK,
     *            IWRK,LIWRK,IERROR)
C
C     SET APPROPRIATE VALUE FOR FAILURE INDICATOR
C
      IF (IERROR.NE.0) IERROR = IERROR + 3
  100 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
C
C     END E01AEF
C
      END

      SUBROUTINE E01AEU(M,X,IP,NP1,B,W)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988).
C
C     *******************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE Q0POLY
C
C     CREATED 02 05 80.  UPDATED 13 05 80.  RELEASE 00/08
C
C     AUTHORS ... GERALD T. ANTHONY, MAURICE G. COX
C                 J. GEOFFREY HAYES AND MICHAEL A. SINGER.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     *******************************************************
C
C     E01AEU.  AN ALGORITHM TO DETERMINE THE CHEBYSHEV SERIES
C     REPRESENTATION OF A ZEROIZING POLYNOMIAL  Q0(X),
C     I.E. A POLYNOMIAL WHICH TAKES ON ZERO VALUES (AND
C     POSSIBLY ZERO DERIVATIVE VALUES) AT SPECIFIED POINTS
C
C     INPUT PARAMETERS
C        M        NUMBER OF DISTINCT X-VALUES.
C        X        INDEPENDENT VARIABLE VALUES,
C                    NORMALIZED TO  (-1, 1)
C        IP       HIGHEST ORDER OF DERIVATIVE AT EACH X-VALUE
C        NP1      N + 1,  WHERE  N = NUMBER OF ZEROS (INCLUDING
C                    THOSE OF DERIVATIVES) TO BE TAKEN ON BY
C                    Q0(X).  N = M + IP(1) + IP(2) + ... + IP(M).
C
C     OUTPUT PARAMETERS
C        B        CHEBYSHEV COEFFICIENTS OF  Q0(X)
C
C     WORKSPACE PARAMETERS
C        W        WORKSPACE
C
C     .. Scalar Arguments ..
      INTEGER           M, NP1
C     .. Array Arguments ..
      DOUBLE PRECISION  B(NP1), W(NP1), X(M)
      INTEGER           IP(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  AI, ANBIG, CT, EPS, FACTOR, ONE, OVFL, PI, RI,
     *                  SFAC, SXTEEN, SXTNTH, TEST, TWO, UNFL, XI,
     *                  XTREMA, ZERO
      INTEGER           I, I2, IFAIL, IP1, K, L, N, NU
C     .. External Functions ..
      DOUBLE PRECISION  X01AAF, X02AJF, X02AMF
      EXTERNAL          X01AAF, X02AJF, X02AMF
C     .. External Subroutines ..
      EXTERNAL          E02AFF
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, LOG, SIN
C     .. Data statements ..
      DATA              ZERO, SXTNTH, ONE, TWO, SXTEEN/0.0D+0,
     *                  0.0625D+0, 1.0D+0, 2.0D+0, 16.0D+0/
C     .. Executable Statements ..
C
C     EVALUATE  Q0(X)  AT THE EXTREMA OF THE CHEBYSHEV POLYNOMIAL
C     OF DEGREE  N,  EMPLOYING DYNAMIC SCALING TO AVOID THE
C     POSSIBILITY OF OVERFLOW OR UNDERFLOW
C
      OVFL = SXTNTH/X02AMF()
      UNFL = SXTNTH*OVFL
      EPS = X02AJF()
      PI = X01AAF(ZERO)
      N = NP1 - 1
      FACTOR = 2*N
      FACTOR = PI/FACTOR
      DO 20 I = 1, NP1
         W(I) = ONE
   20 CONTINUE
      DO 120 K = 1, M
         IP1 = IP(K) + 1
         XI = X(K)
         DO 100 L = 1, IP1
            ANBIG = ZERO
            I2 = N + 2
            DO 40 I = 1, NP1
               I2 = I2 - 2
               RI = I2
               XTREMA = SIN(FACTOR*RI)
               AI = W(I)*(XTREMA-XI)
               W(I) = AI
               IF (ABS(AI).GT.ANBIG) ANBIG = ABS(AI)
   40       CONTINUE
   60       SFAC = ONE
            IF (ANBIG.GT.OVFL) SFAC = SXTNTH
            IF (ANBIG.LT.UNFL) SFAC = SXTEEN
            IF (SFAC.EQ.ONE) GO TO 100
            ANBIG = ANBIG*SFAC
            DO 80 I = 1, NP1
               W(I) = W(I)*SFAC
   80       CONTINUE
            GO TO 60
  100    CONTINUE
  120 CONTINUE
      CT = OVFL
      DO 140 I = 1, NP1
         TEST = ABS(W(I))/ANBIG
         IF (TEST.LE.EPS) W(I) = ZERO
         IF (TEST.GT.EPS .AND. TEST.LT.CT) CT = TEST
  140 CONTINUE
      CT = CT*ANBIG
      SFAC = ONE
  160 IF (CT.LT.ONE) GO TO 180
      CT = CT*SXTNTH
      SFAC = SFAC*SXTNTH
      GO TO 160
  180 DO 200 I = 1, NP1
         W(I) = W(I)*SFAC
  200 CONTINUE
C
C     DETERMINE THE CHEBYSHEV REPRESENTATION OF  Q0(X)
C
      CALL E02AFF(NP1,W,B,IFAIL)
C
C     SET THE LEADING COEFFICIENT OF  Q0(X)  TO AN
C     EXACT POWER OF  2
C
      AI = B(NP1)
      CT = LOG(ABS(AI))/LOG(TWO)
      NU = CT
      SFAC = TWO**NU
      B(NP1) = SFAC
      SFAC = SFAC/AI
      DO 220 I = 1, N
         B(I) = B(I)*SFAC
  220 CONTINUE
C
      RETURN
C
C     END E01AEU
C
      END

      SUBROUTINE E01AEV(WITHQ0,WITHPI,M,XMIN,XMAX,X,N,Y,IP,IMAX,A,LA,IT,
     *                  RNMBST,RNM,IMPROV,ADIF,RES,PMAX,PINDEX)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988).
C
C     *******************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE PRESID
C
C     CREATED 18 02 80.  UPDATED 14 05 80.  RELEASE 00/28
C
C     AUTHOR ... MAURICE G. COX.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND
C
C     *******************************************************
C
C     E01AEV.  FORMS PERFORMANCE INDICES AND RESIDUALS
C     FOR A POLYNOMIAL APPROXIMATION  P(X)  TO A SET OF DATA
C     WHICH MAY CONTAIN DERIVATIVE VALUES.  ALSO INDICATES
C     WHETHER THE POLYNOMIAL DEFINED BY THE SPECIFIED
C     COEFFICIENTS IS A BETTER APPROXIMATION THAN THE BEST
C     SO FAR.
C
C     INPUT PARAMETERS
C        WITHQ0   TRUE IF ZEROIZING POLYNOMIAL, ELSE FALSE
C        WITHPI   IF TRUE, PERFORMANCE INDICES PRODUCED UNDER
C                    ALL CIRCUMSTANCES.  OTHERWISE, PRODUCED
C                    ONLY IF  P(X)  IS AN IMPROVEMENT
C        M        NUMBER OF X-VALUES.  ALL DISTINCT
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C        X        X-VALUES.  NORMALIZED TO  (-1, 1)
C        N        NUMBER OF Y-VALUES
C        Y        VALUES AND DERIVATIVES OF DEPENDENT VARIABLE
C        IP       HIGHEST ORDER OF DERIVATIVE AT EACH X-VALUE
C        IMAX     ONE GREATER THAN LARGEST VALUE OF  IP
C        A        CHEBYSHEV COEFFICIENTS OF  P(X)
C        LA       DIMENSION OF  A  AND  ADIF.
C                    .GE. N + 1 IF WITHQ0 IS TRUE,
C                    .GE. N     OTHERWISE
C        IT       ITERATION NUMBER
C
C     INPUT/OUTPUT PARAMETERS
C        RNMBST   2-NORMS OF RESIDUALS CORRESPONDING TO THE
C                    BEST POLYNOMIAL SO FAR AND ITS DERIVATIVES
C
C     OUTPUT PARAMETERS
C        RNM      2-NORMS OF RESIDUALS CORRESPONDING TO
C                    P(X)  AND ITS DERIVATIVES
C        IMPROV   TRUE IF  P(X)  IS AN IMPROVEMENT, ELSE FALSE
C        ADIF     CHEBYSHEV COEFFICIENTS OF  (IMAX - 1)-ST
C                    DERIVATIVE OF  P(X)
C        RES      RESIDUALS CORRESPONDING TO Y-VALUES
C      * PMAX     LARGEST PERFORMANCE INDEX
C      * PINDEX   PERFORMANCE INDICES
C
C     NOTE.  THE PARAMETERS MARKED  *  ARE PROVIDED ONLY
C            IF  IMPROV  IS TRUE
C
C     KEY LOCAL VARIABLES
C        ASUMAX   FOR CURRENT VALUE OF  L,  MAXIMUM VALUE
C                    OVER  J = 0, 1, ..., L  OF SUM OF MODULI
C                    OF CHEBYSHEV COEFFICIENTS OF DERIVATIVE
C                    OF ORDER  J  OF  P(X)
C        EPS      RELATIVE MACHINE PRECISION
C        IY       LOCATION IN  Y  OF CURRENT SPECIFIED
C                    DERIVATIVE VALUE OF ORDER  L
C        NL       NUMBER OF SPECIFIED DERIVATIVE VALUES
C                    OF ORDER  L
C        NTERMS   NUMBER OF TERMS IN CHEBYSHEV SERIES
C                    REPRESENTATION OF CURRENT DERIVATIVE
C                    OF  P(X)
C        RES2NM   2-NORM OF THE RESIDUALS CORRESPONDING TO THE
C                    SPECIFIED DERIVATIVE VALUES OF ORDER  L - 1
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  PMAX, XMAX, XMIN
      INTEGER           IMAX, IT, LA, M, N
      LOGICAL           IMPROV, WITHPI, WITHQ0
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LA), ADIF(LA), PINDEX(IMAX), RES(N),
     *                  RNM(IMAX), RNMBST(IMAX), X(M), Y(N)
      INTEGER           IP(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  ABSRES, ASUM, ASUMAX, EPS, HALF, MLTPLR, ONE, P,
     *                  PLARGE, RESMAX, RSCALE, T, ZERO
      INTEGER           I, IA, IY, L, LM1, NL, NTERMS
      LOGICAL           IMP
C     .. External Functions ..
      DOUBLE PRECISION  X02AJF
      EXTERNAL          X02AJF
C     .. External Subroutines ..
      EXTERNAL          E02AHZ, E02AKZ
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Data statements ..
      DATA              HALF, ZERO, ONE, MLTPLR/0.5D+0, 0.0D+0, 1.0D+0,
     *                  8.0D+0/
C     .. Executable Statements ..
      PMAX = ZERO
      EPS = X02AJF()
      NTERMS = N
      IF (WITHQ0) NTERMS = NTERMS + 1
      ASUMAX = ZERO
      DO 20 I = 1, NTERMS
         ADIF(I) = A(I)
   20 CONTINUE
      NTERMS = NTERMS + 1
      DO 120 L = 1, IMAX
         NTERMS = NTERMS - 1
C
C        DETERMINE SUM OF MODULI  ASUM  OF CHEBYSHEV COEFFICIENTS
C        OF DERIVATIVE OF ORDER  L - 1  OF  P(X),  AND UPDATE
C        ASUMAX
C
         ASUM = HALF*ABS(ADIF(1))
         IF (NTERMS.EQ.1) GO TO 60
         DO 40 IA = 2, NTERMS
            ASUM = ASUM + ABS(ADIF(IA))
   40    CONTINUE
   60    IF (ASUM.GT.ASUMAX) ASUMAX = ASUM
C
C        PINDEX(L)  IS USED TEMPORARILY TO HOLD THE
C        VALUE OF  ASUMAX
C
         PINDEX(L) = ASUMAX
         IY = L
         NL = 0
C
C        TO REDUCE THE POSSIBILITY OF UNDERFLOW AND OVERFLOW,
C        COMPUTE  RES2NM  AS  RESMAX*SQRT(RSCALE),  WHERE
C        RESMAX  AND  RSCALE  ARE UPDATED FOR EACH RESIDUAL
C        CORRESPONDING TO A SPECIFIED DERIVATIVE VALUE OF
C        ORDER  L - 1.  AT ANY STAGE,  RESMAX  HOLDS THE
C        MODULUS OF THE RESIDUAL OF MAXIMUM MAGNITUDE SO FAR,
C        AND  RSCALE  THE SUM SO FAR OF THE SQUARES OF THE
C        RESIDUALS, EACH SCALED BY  RESMAX.
C
         RESMAX = ZERO
         RSCALE = ONE
         DO 100 I = 1, M
C
C           SKIP IF NO DERIVATIVE VALUE OF ORDER  L - 1  IS
C           SPECIFIED AT  I-TH  X-VALUE
C
            IF (IP(I)+1.LT.L) GO TO 80
            NL = NL + 1
C
C           EVALUATE  P,  THE  (L - 1)-ST  DERIVATIVE OF  P(X)
C           AT  X = X(I)
C
            CALL E02AKZ(NTERMS,ADIF,1,LA,X(I),P)
C
C           SAVE RESIDUAL CORRESPONDING TO THIS VALUE
C
            IF (WITHQ0) RES(IY) = -P
            IF ( .NOT. WITHQ0) RES(IY) = Y(IY) - P
C
C           UPDATE  RESMAX  AND  RSCALE
C
            ABSRES = ABS(RES(IY))
            IF (ABSRES.NE.ZERO .AND. ABSRES.LE.RESMAX) RSCALE = RSCALE +
     *          (ABSRES/RESMAX)**2
            IF (ABSRES.NE.ZERO .AND. ABSRES.GT.RESMAX)
     *          RSCALE = RSCALE*(RESMAX/ABSRES)**2 + ONE
            IF (ABSRES.NE.ZERO .AND. ABSRES.GT.RESMAX) RESMAX = ABSRES
   80       IY = IY + IP(I) + 1
  100    CONTINUE
         RNM(L) = RESMAX*SQRT(RSCALE)
C
C        FORM COEFFICIENTS IN CHEBYSHEV SERIES REPRESENTATION
C        OF  L-TH  DERIVATIVE OF  P(X)  FROM THOSE OF
C        (L - 1)-ST DERIVATIVE
C
         IF (L.LT.IMAX) CALL E02AHZ(NTERMS,XMIN,XMAX,ADIF,1,LA,T,ADIF,1,
     *                              LA)
  120 CONTINUE
C
C     IF NOT ON ZERO-TH ITERATION,
C     DETECT WHETHER THERE HAS BEEN AN IMPROVEMENT ...
C
      IMP = (IT.EQ.0)
      IF (IMP) GO TO 160
      DO 140 L = 1, IMAX
         IF (RNM(L).LT.RNMBST(L)) IMP = .TRUE.
  140 CONTINUE
      IF ( .NOT. (IMP .OR. WITHPI)) GO TO 220
C
C     ... AND, IF SO, OR IF ZERO-TH ITERATION, OR IF
C     THEY ARE REQUIRED ANYWAY, FORM THE PERFORMANCE
C     INDICES CORRESPONDING TO THE IMPROVED
C     APPROXIMATION
C
  160 PLARGE = ZERO
      DO 200 L = 1, IMAX
C
C        NL  IS THE NUMBER OF DERIVATIVE VALUES OF ORDER  L - 1
C
         NL = 0
         LM1 = L - 1
         DO 180 I = 1, M
            IF (IP(I).GE.LM1) NL = NL + 1
  180    CONTINUE
         T = NL
C
C        RETRIEVE THE VALUE OF ASUMAX
C
         ASUMAX = PINDEX(L)
         IF (ASUMAX.NE.ZERO) PINDEX(L) = RNM(L)
     *       /(MLTPLR*EPS*ASUMAX*SQRT(T))
         IF (ASUMAX.EQ.ZERO) PINDEX(L) = ZERO
         IF (PINDEX(L).GT.PLARGE) PLARGE = PINDEX(L)
  200 CONTINUE
      PMAX = PLARGE
  220 IMPROV = IMP
      RETURN
C
C     END E01AEV
C
      END

      SUBROUTINE E01AEW(M,XMIN,XMAX,X,Y,IP,N,NP1,ITMIN,ITMAX,A,B,WRK,
     *                  LWRK,IWRK,LIWRK,IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     *******************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE PNTRPA
C
C     CREATED 20 12 79.  UPDATED 13 05 80.  RELEASE 00/47
C
C     AUTHORS ... GERALD T. ANTHONY, MAURICE G. COX,
C                 J. GEOFFREY HAYES AND MICHAEL A. SINGER.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND
C
C     *******************************************************
C
C     E01AEW. A ROUTINE, WITHOUT CHECKS, WHICH DETERMINES AND
C     REFINES A POLYNOMIAL INTERPOLANT  Q(X)  TO DATA WHICH
C     MAY CONTAIN DERIVATIVES, AND AN ASSOCIATED ZEROIZING
C     POLYNOMIAL  Q0(X).
C
C        M        NUMBER OF DISTINCT X-VALUES
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C        X        INDEPENDENT VARIABLE VALUES (DISTINCT)
C        Y        VALUES AND DERIVATIVES OF
C                    DEPENDENT VARIABLE.
C        IP       HIGHEST ORDER OF DERIVATIVE AT EACH X-VALUE.
C        N        NUMBER OF INTERPOLATING CONDITIONS.
C                    N = M + IP(1) + IP(2) + ... + IP(M).
C        NP1      VALUE OF  N + 1
C        ITMIN,
C        ITMAX    MINIMUM AND MAXIMUM NUMBER OF ITERATIONS TO BE
C                    PERFORMED.
C        IWRK(1)  SEE WORKSPACE (AND ASSOCIATED
C                    DIMENSION) PARAMETERS
C
C     OUTPUT PARAMETERS
C        A        CHEBYSHEV COEFFICIENTS OF  Q(X)
C        B        CHEBYSHEV COEFFICIENTS OF  Q0(X)
C
C     WORKSPACE (AND ASSOCIATED DIMENSION) PARAMETERS
C        WRK      REAL WORKSPACE ARRAY.  THE FIRST IMAX ELEMENTS
C                    CONTAIN, ON EXIT, PERFORMANCE INDICES FOR
C                    THE INTERPOLATING POLYNOMIAL, AND THE NEXT
C                    N  ELEMENTS THE COMPUTED RESIDUALS
C        LWRK     DIMENSION OF WRK. LWRK MUST BE AT LEAST
C                    8*N + 5*IMAX + M + 5, WHERE
C                    IMAX IS ONE MORE THAN THE LARGEST ELEMENT
C                    OF THE ARRAY IP.
C        IWRK     INTEGER WORKSPACE ARRAY.
C                    THE FIRST ELEMENT OF THIS ARRAY IS USED
C                    AS AN INPUT PARAMETER (WHICH IS DESTROYED
C                    ON EXIT).  THE ZEROIZING POLYNOMIAL  Q0(X)
C                    IS CONSTRUCTED OR NOT ACCORDING TO WHETHER
C                    IWRK(1)  IS NON-ZERO OR ZERO.
C        LIWRK    DIMENSION OF IWRK.  AT LEAST 2*M + 2.
C
C     FAILURE INDICATOR PARAMETER
C        IFAIL    FAILURE INDICATOR
C                    0 - SUCCESSFUL TERMINATION
C                    1 - ITERATION LIMIT IN DERIVING  Q(X)
C                    2 - DIVERGENT ITERATION IN DERIVING  Q(X)
C                    3 - ITERATION LIMIT IN DERIVING  Q0(X)
C                    4 - DIVERGENT ITERATION IN DERIVING  Q0(X)
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           IFAIL, ITMAX, ITMIN, LIWRK, LWRK, M, N, NP1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(N), B(NP1), WRK(LWRK), X(M), Y(N)
      INTEGER           IP(M), IWRK(LIWRK)
C     .. Local Scalars ..
      DOUBLE PRECISION  ONE, PMAX, TWO, ZERO
      INTEGER           I, IADIF, IATRL, IBDIF, IBTRL, IC, ID, IDA, IDB,
     *                  IERROR, IFTAU, ILOCX, ILOCY, IMAX, INITQ,
     *                  INITQ0, IPIQ, IPIQ0, IPTRL, IRES, IRNM, IRTRNM,
     *                  IW, IX
      LOGICAL           WITHQ0
C     .. External Subroutines ..
      EXTERNAL          E01AEY, E02AKY
C     .. Data statements ..
      DATA              ZERO, ONE, TWO/0.0D+0, 1.0D+0, 2.0D+0/
C     .. Executable Statements ..
      IERROR = 0
      IMAX = 0
      DO 20 I = 1, M
         IF (IP(I).GT.IMAX) IMAX = IP(I)
   20 CONTINUE
      IMAX = IMAX + 1
C
C     INDICATE WHETHER  Q0(X)  IS REQUIRED
C
      WITHQ0 = (IWRK(1).NE.0)
C
C     TREAT THE CASE N = 1 SEPARATELY.
C
      IF (N.NE.1) GO TO 60
      A(1) = TWO*Y(1)
      IF ( .NOT. WITHQ0) GO TO 40
      CALL E02AKY(XMIN,XMAX,X(1),B(1))
      B(1) = -TWO*B(1)
      B(2) = ONE
C
C     SET TO ZERO THE NUMBERS OF ITERATIONS TAKEN, THE (SOLE)
C     RESIDUAL AND THE VALUES OF THE PERFORMANCE INDICES
C     IN THIS SPECIAL CASE, AND FINISH
C
   40 IWRK(1) = 0
      IF (WITHQ0) IWRK(2) = 0
      WRK(1) = ZERO
      WRK(2) = ZERO
      IF (WITHQ0) WRK(3) = ZERO
C
C     TRANSFORM THE  X*S  TO  (-1, 1)
C
   60 IX = 2*IMAX + N
      DO 80 I = 1, M
         IX = IX + 1
         CALL E02AKY(XMIN,XMAX,X(I),WRK(IX))
   80 CONTINUE
      IF (N.EQ.1) GO TO 120
      IF ( .NOT. WITHQ0) GO TO 100
C
C     WORKSPACE ALLOCATION FOR CALL TO  E01AEY  ...
C
      IRES = IMAX + 1
      IPIQ0 = IRES + N
      IX = IPIQ0 + IMAX
      IBTRL = IX + M
      IPTRL = IBTRL + NP1
      IFTAU = IPTRL + IMAX
      IC = IFTAU + N
      ID = IC + N
      IW = ID + NP1
      IBDIF = IW + NP1
      IDB = IBDIF + NP1
      IRNM = IDB + NP1
      IRTRNM = IRNM + IMAX
      INITQ0 = 2
      ILOCX = INITQ0 + 1
      ILOCY = ILOCX + M
C
C     ... TO DETERMINE  Q0(X)
C
      CALL E01AEY(.TRUE.,M,WRK(IX),XMIN,XMAX,Y,IP,IMAX,N,NP1,ITMIN,
     *            ITMAX,B,NP1,WRK(IRES),PMAX,WRK(IPIQ0),IWRK(INITQ0)
     *            ,WRK(IBTRL),WRK(IPTRL),WRK(IFTAU),WRK(IC),WRK(ID)
     *            ,WRK(IW),WRK(IBDIF),WRK(IDB),WRK(IRNM),WRK(IRTRNM)
     *            ,IWRK(ILOCX),IWRK(ILOCY),IERROR)
C
C     RE-CODE FAILURE INDICATOR
C
      IF (IERROR.NE.0) IERROR = IERROR + 2
      IF (IERROR.NE.0) GO TO 120
C
C     WORKSPACE ALLOCATION FOR CALL TO  E01AEY  ...
C
  100 IPIQ = 1
      IRES = IPIQ + IMAX
      IX = IRES + N + IMAX
      IATRL = IX + M
      IPTRL = IATRL + N
      IFTAU = IPTRL + IMAX
      IC = IFTAU + N
      ID = IC + N
      IW = ID + N
      IADIF = IW
      IDA = IADIF + NP1
      IRNM = IDA + NP1
      IRTRNM = IRNM + IMAX
      INITQ = 1
      ILOCX = INITQ + 2
      ILOCY = ILOCX + M
C
C     ... TO DETERMINE  Q(X)
C
      CALL E01AEY(.FALSE.,M,WRK(IX),XMIN,XMAX,Y,IP,IMAX,N,NP1,ITMIN,
     *            ITMAX,A,N,WRK(IRES),PMAX,WRK(IPIQ),IWRK(INITQ)
     *            ,WRK(IATRL),WRK(IPTRL),WRK(IFTAU),WRK(IC),WRK(ID)
     *            ,WRK(IW),WRK(IADIF),WRK(IDA),WRK(IRNM),WRK(IRTRNM)
     *            ,IWRK(ILOCX),IWRK(ILOCY),IERROR)
C
  120 IFAIL = IERROR
      RETURN
C
C     END E01AEW
C
      END

      SUBROUTINE E01AEX(M,X,IP,N,LOCX,C,NC,XNEW,IXNEXT,YNEW,NORDP1,CNEW,
     *                  D)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     *******************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE DIVDIF
C
C     CREATED 17 07 79.  UPDATED 14 05 80.  RELEASE 00/08
C
C     AUTHORS ... MAURICE G. COX AND MICHAEL A. SINGER.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND
C
C     *******************************************************
C
C     E01AEX.  AN ALGORITHM TO DETERMINE THE NEXT COEFFICIENT
C     IN THE NEWTON FORM OF AN INTERPOLATING POLYNOMIAL
C
C     INPUT PARAMETERS
C        M        NUMBER OF DISTINCT X-VALUES.
C        X        INDEPENDENT VARIABLE VALUES,
C                    NORMALIZED TO  (-1, 1)
C        IP       HIGHEST ORDER OF DERIVATIVE AT EACH X-VALUE
C        N        NUMBER OF INTERPOLATING CONDITIONS.
C                    N = M + IP(1) + IP(2) + ... + IP(M).
C        LOCX     POINTERS TO X-VALUES IN CONSTRUCTING
C                    NEWTON FORM OF POLYNOMIAL
C        C        NEWTON COEFFICIENTS DETERMINED SO FAR
C        NC       NUMBER OF NEWTON COEFFICIENTS DETERMINED SO FAR
C        XNEW     ELEMENT OF  X  ASSOCIATED WITH NEW
C                    NEWTON COEFFICIENT
C        IXNEXT   NUMBER OF X-VALUES SO FAR INCORPORATED
C                    (INCLUDING  XNEW)
C        YNEW     SCALED DERIVATIVE VALUE CORRESPONDING TO
C                    XNEW  AND  NORDP1
C        NORDP1   ONE PLUS ORDER OF DERIVATIVE
C                    ASSOCIATED WITH  YNEW
C
C     INPUT/OUTPUT PARAMETERS
C        D        ELEMENTS IN PREVIOUS, AND THEN NEW, UPWARD
C                    SLOPING DIAGONAL OF DIVIDED DIFFERENCE TABLE
C
C     OUTPUT PARAMETERS
C        CNEW     NEW NEWTON COEFFICIENT GENERATED
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  CNEW, XNEW, YNEW
      INTEGER           IXNEXT, M, N, NC, NORDP1
C     .. Array Arguments ..
      DOUBLE PRECISION  C(N), D(N), X(M)
      INTEGER           IP(M), LOCX(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  DIF
      INTEGER           IC, IS, IX, K, LOCXI
C     .. Executable Statements ..
      IC = NC - NORDP1 + 1
      D(1) = YNEW
      IF (IXNEXT.EQ.1) GO TO 60
      IS = 0
      IX = 0
      DO 40 K = 1, IC
         IF (K.LE.IS) GO TO 20
         IX = IX + 1
         LOCXI = LOCX(IX)
         IS = IS + IP(LOCXI) + 1
         DIF = X(LOCXI) - XNEW
   20    IF (NORDP1.EQ.1) D(K+1) = (C(K)-D(K))/DIF
         IF (NORDP1.GT.1) D(K+1) = (D(K+1)-D(K))/DIF
   40 CONTINUE
   60 CNEW = D(IC+1)
      RETURN
C
C     END E01AEX
C
      END

      SUBROUTINE E01AEY(WITHQ0,M,X,XMIN,XMAX,Y,IP,IMAX,N,NP1,ITMIN,
     *                  ITMAX,A,LA,RES,PMAX,PINDEX,NIT,ATRIAL,PTRIAL,
     *                  FTAU,C,D,W,ADIF,DA,RNM,RTRLNM,LOCX,LOCY,IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     *******************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE REFH
C
C     CREATED 17 07 79.  UPDATED 14 05 80.  RELEASE 00/47
C
C     AUTHORS ... GERALD T. ANTHONY, MAURICE G. COX
C                 J. GEOFFREY HAYES AND MICHAEL A. SINGER.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND
C
C     *******************************************************
C
C     E01AEY.  A ROUTINE TO APPROXIMATE AND THEN REFINE AN
C     INTERPOLATING POLYNOMIAL  Q(X)  OR A ZEROIZING
C     POLYNOMIAL  Q0(X)  IN ITS CHEBYSHEV REPRESENTATION
C
C     INPUT PARAMETERS
C        WITHQ0   TRUE IF ZEROIZING POLYNOMIAL, ELSE FALSE
C        M        THE NUMBER OF DISTINCT DATA POINTS.
C        X        ARRAY CONTAINING THE DISTINCT X-VALUES,
C                    NORMALIZED IF NECESSARY TO (-1, 1).
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C      * Y        ARRAY CONTAINING VALUES AND DERIVATIVES OF
C                    THE DEPENDENT VARIABLE.
C        IP       ARRAY SPECIFYING THE HIGHEST ORDER OF
C                    DERIVATIVE AT EACH X-VALUE.
C        IMAX     ONE MORE THAN THE LARGEST ELEMENT OF THE
C                    ARRAY IP.
C        N        NUMBER OF INTERPOLATING CONDITIONS.
C                    N = M + IP(1) + IP(2) + ... + IP(M).
C        NP1      VALUE OF  N + 1
C        ITMIN,
C        ITMAX    THE LOWER AND UPPER LIMITS ON THE ITERATIVE
C                    PROCESS.
C
C     OUTPUT (AND ASSOCIATED DIMENSION) PARAMETERS
C        A        CHEBYSHEV COEFFICIENTS OF POLYNOMIAL
C        LA       DIMENSION OF  A.
C                    .GE. N  IF INTERPOLATING POLYNOMIAL
C                    .GE. N + 1  IF ZEROIZING POLYNOMIAL
C        RES      RESIDUALS OF POLYNOMIAL
C        PMAX     LARGEST PERFORMANCE INDEX
C        PINDEX   PERFORMANCE INDICES
C        NIT      NUMBER OF ITERATIONS TAKEN
C
C     WORKSPACE PARAMETERS
C        ATRIAL   TRIAL VALUES OF THE CHEBYSHEV COEFFICIENTS
C        PTRIAL   PERFORMANCE INDICES CORRESPONDING TO  ATRIAL
C      * FTAU     SCALED VALUES OF  Y.  IF  Y(I)  IS THE
C                    VALUE OF AN  R-TH  DERIVATIVE, THEN
C                    ((XMAX - XMIN)/2)**R/(FACTORIAL R)
C                    TIMES  Y(I)  IS THE VALUE OF  FTAU(I)
C      * C        COEFFICIENTS IN NEWTON FORM OF POLYNOMIAL
C      * D        INTERMEDIATE DIVIDED DIFFERENCE VALUES
C      **W        VALUES OF CORRECTION POLYNOMIAL AT
C                    CHEBYSHEV EXTREMA
C        ADIF     CHEBYSHEV COEFFICIENTS OF A DERIVATIVE OF
C                    AN APPROXIMATION TO THE POLYNOMIAL
C        DA       CHEBYSHEV COEFFICIENTS OF A
C                    CORRECTION POLYNOMIAL
C        RNM      RESIDUAL NORMS CORRESPONDING TO  A
C        RTRLNM   RESIDUAL NORMS CORRESPONDING TO  ATRIAL
C      * LOCX     POINTERS TO X-VALUES IN CONSTRUCTING
C                    NEWTON FORM OF POLYNOMIAL
C      * LOCY     POINTERS TO Y-VALUES CORRESPONDING TO X-VALUES
C
C     FAILURE INDICATOR PARAMETER
C        IFAIL    FAILURE INDICATOR
C                    0 - SUCCESSFUL TERMINATION
C                    1 - ITERATION LIMIT EXCEEDED
C                    2 - ITERATION DIVERGENT
C
C           NOTES.  (1) THE ELEMENTS OF THE ARRAYS MARKED  *  ARE
C                       NOT ACCESSED IF  WITHQ0  IS  TRUE.
C                   (2) THE ELEMENTS OF THE ARRAY MARKED  **  IS
C                       NOT ACCESSED IF  WITHQ0  IS  FALSE.
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  PMAX, XMAX, XMIN
      INTEGER           IFAIL, IMAX, ITMAX, ITMIN, LA, M, N, NIT, NP1
      LOGICAL           WITHQ0
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LA), ADIF(LA), ATRIAL(LA), C(N), D(N), DA(LA),
     *                  FTAU(N), PINDEX(IMAX), PTRIAL(IMAX), RES(N),
     *                  RNM(IMAX), RTRLNM(IMAX), W(NP1), X(M), Y(N)
      INTEGER           IP(M), LOCX(M), LOCY(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  AMAX, ATRNRM, DANRM, HALF, ONE, PMXTRL, SCALE,
     *                  SXTEEN, ZERO
      INTEGER           I, IERROR, IT, ITEMP, ITMXP1, ITP1, L, NFREF,
     *                  NPILT1, NTERMS
      LOGICAL           IMPROV, WITHPI, ZERODA
C     .. External Subroutines ..
      EXTERNAL          E01AEU, E01AEV, E01AEZ
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, LOG
C     .. Data statements ..
      DATA              ZERO, HALF, ONE, SXTEEN/0.0D+0, 0.5D+0, 1.0D+0,
     *                  16.0D+0/
C     .. Executable Statements ..
      IERROR = 0
C
C     NUMBER OF TERMS IN POLYNOMIAL
C
      NTERMS = N
      IF (WITHQ0) NTERMS = NTERMS + 1
C
C     NUMBER OF PERFORMANCE INDICES LESS THAN ONE
C
      NPILT1 = 0
C
C     INDICATE THAT PERFORMANCE INDICES ARE TO BE PRODUCED
C     ONLY IF AN IMPROVEMENT IS OBTAINED
C
      WITHPI = .FALSE.
C
C     INDICATE THAT THE FINE REFINEMENT STAGE HAS NOT YET STARTED
C
      NFREF = -2
C
C     SET RESIDUALS INITIALLY EQUAL TO SPECIFIED Y-VALUES
C     (IF  Q(X)  REQUIRED) OR ZERO (IF  Q0(X)  REQUIRED)
C
      DO 20 I = 1, N
         IF ( .NOT. WITHQ0) RES(I) = Y(I)
         IF (WITHQ0) RES(I) = ZERO
   20 CONTINUE
C
C     INITIALIZE TRIAL CHEBYSHEV COEFFICIENTS
C
      DO 40 I = 1, NTERMS
         ATRIAL(I) = ZERO
   40 CONTINUE
C
C     COMMENCE ITERATIVE REFINEMENT
C
      ITMXP1 = ITMAX + 1
      DO 360 ITP1 = 1, ITMXP1
C
C        IT  IS THE ACTUAL ITERATION NUMBER,  IT = 0
C        CORRESPONDING TO THE FIRST ESTIMATE OF THE POLYNOMIAL
C
         IT = ITP1 - 1
C
C        DETERMINE CHEBYSHEV COEFFICIENTS  DA  OF POLYNOMIAL
C        APPROXIMATELY SATISFYING THE CONDITIONS IN  RES
C
         IF (WITHQ0 .AND. IT.EQ.0) CALL E01AEU(M,X,IP,NP1,DA,W)
         IF ( .NOT. WITHQ0 .OR. (WITHQ0 .AND. IT.GT.0))
     *       CALL E01AEZ(M,XMIN,XMAX,X,RES,IP,N,DA,LOCX,LOCY,FTAU,D,C)
C
C        SKIP TEST FOR DIVERGENCE IF ON ZERO-TH ITERATION
C
         IF (IT.EQ.0) GO TO 100
C
C        DETERMINE THE NORMS OF  DA  AND (THE PREVIOUS)  ATRIAL
C
         DANRM = HALF*ABS(DA(1))
         ATRNRM = HALF*ABS(ATRIAL(1))
         IF (N.EQ.1) GO TO 80
         DO 60 I = 2, N
            DANRM = DANRM + ABS(DA(I))
            ATRNRM = ATRNRM + ABS(ATRIAL(I))
   60    CONTINUE
   80    IF (WITHQ0) ATRNRM = ATRNRM + ABS(ATRIAL(NP1))
C
C        ASSUME DIVERGENCE IF THE NORM OF  DA  IS NOT
C        LESS THAN THAT OF  ATRIAL  ...
C
         IF (DANRM.GE.ATRNRM) IERROR = 2
         IF (DANRM.GE.ATRNRM) GO TO 380
C
C        ... OTHERWISE DETERMINE NEW TRIAL APPROXIMATION
C
  100    ZERODA = .TRUE.
         DO 120 I = 1, N
            ATRIAL(I) = ATRIAL(I) + DA(I)
            IF (DA(I).NE.ZERO) ZERODA = .FALSE.
  120    CONTINUE
         IF ( .NOT. (WITHQ0 .AND. IT.EQ.0)) GO TO 140
         ATRIAL(NP1) = DA(NP1)
         IF (DA(NP1).NE.ZERO) ZERODA = .FALSE.
C
C        DETERMINE RESIDUALS, PERFORMANCE INDICES AND
C        LARGEST PERFORMANCE INDEX CORRESPONDING TO
C        TRIAL COEFFICIENTS  ATRIAL
C
  140    CALL E01AEV(WITHQ0,WITHPI,M,XMIN,XMAX,X,N,Y,IP,IMAX,ATRIAL,LA,
     *               IT,RNM,RTRLNM,IMPROV,ADIF,RES,PMXTRL,PTRIAL)
C
C        SET DUMMY, NON-ZERO, VALUE OF  PMXTRL  IF NO
C        IMPROVEMENT, OTHERWISE IT IS UNDEFINED
C
         IF ( .NOT. IMPROV) PMXTRL = SXTEEN
C
C        IF ON FIRST ITERATION, OR IF THE LARGEST PERFORMANCE
C        INDEX IS ZERO, OR IF ALL COMPONENTS OF  DA  ARE ZERO,
C        TAKE THE TRIAL SET OF COEFFICIENTS AND PERFORMANCE
C        INDICES AS THE BEST (SO FAR)
C
         IF ( .NOT. (IT.EQ.0 .OR. PMXTRL.EQ.ZERO .OR. ZERODA))
     *       GO TO 200
         DO 160 I = 1, NTERMS
            A(I) = ATRIAL(I)
  160    CONTINUE
         DO 180 L = 1, IMAX
            RNM(L) = RTRLNM(L)
            PINDEX(L) = PTRIAL(L)
  180    CONTINUE
         PMAX = PMXTRL
C
C        FINISH IF LARGEST PERFORMANCE INDEX IS ZERO
C        OR IF ALL COMPONENTS OF  DA  ARE ZERO
C        (I.E. NO FURTHER IMPROVEMENT IS POSSIBLE)
C
  200    IF (PMXTRL.EQ.ZERO .OR. ZERODA) GO TO 380
C
C        INDICATE WHETHER THE FINE REFINEMENT STAGE HAS COMMENCED
C        (I.E. FOR THE FIRST TIME ALL PERFORMANCE INDICES ARE
C        LESS THAN ONE)
C
         IF (NFREF.EQ.-2 .AND. PMXTRL.LT.ONE) NFREF = -1
C
C        BRANCH ACCORDING TO WHETHER THE PROCESS IS IN THE
C        FINE REFINEMENT STAGE  (NFREF .GE. 0)  OR NOT
C        (NFREF .EQ. -1)
C
         IF (NFREF.GE.-1) GO TO 280
C
C        THE PROCESS IS IN THE COURSE REFINEMENT PHASE.
C        UPDATE THE COEFFICIENTS AND THE CORRESPONDING
C        NORMS AND PERFORMANCE INDICES IF
C           (I)  THERE HAS BEEN AN IMPROVEMENT IN (AT
C                LEAST) ONE OF THE RESIDUAL NORMS, AND
C           (II) THE NUMBER OF PERFORMANCE INDICES
C                THAT ARE LESS THAN ONE HAS NOT
C                INCREASED COMPARED WITH THOSE OF
C                THE BEST POLYNOMIAL SO FAR.
C
         IF ( .NOT. IMPROV) GO TO 360
         ITEMP = 0
         DO 220 L = 1, IMAX
            IF (PTRIAL(L).LT.ONE) ITEMP = ITEMP + 1
  220    CONTINUE
         IF (ITEMP.LT.NPILT1) GO TO 360
         NPILT1 = ITEMP
         DO 240 I = 1, NTERMS
            A(I) = ATRIAL(I)
  240    CONTINUE
         DO 260 L = 1, IMAX
            RNM(L) = RTRLNM(L)
            PINDEX(L) = PTRIAL(L)
  260    CONTINUE
         PMAX = PMXTRL
         GO TO 360
C
C        THE PROCESS IS IN THE FINE REFINEMENT PHASE.
C        UPDATE THE COEFFICIENTS AND THE CORRESPONDING
C        NORMS AND PERFORMANCE INDICES IF
C           (I)  THERE HAS BEEN AN IMPROVEMENT IN (AT
C                LEAST) ONE OF THE RESIDUAL NORMS, AND
C           (II) THE LARGEST PERFORMANCE INDEX IS LESS
C                THAN THE LARGEST OF THAT OF THE BEST
C                POLYNOMIAL SO FAR.
C        INCREMENT THE NUMBER OF FINE REFINEMENTS (THE NUMBER
C        OF REFINEMENTS SINCE THE FIRST OCCASION WHEN ALL
C        PERFORMANCE INDICES WERE LESS THAN UNITY), EXITING
C        IF AS MANY AS  ITMIN  FINE REFINEMENTS HAVE BEEN
C        PERFORMED
C
  280    IF ( .NOT. IMPROV) GO TO 340
         IF (PMXTRL.GE.PMAX) GO TO 340
         DO 300 I = 1, NTERMS
            A(I) = ATRIAL(I)
  300    CONTINUE
         DO 320 L = 1, IMAX
            RNM(L) = RTRLNM(L)
            PINDEX(L) = PTRIAL(L)
  320    CONTINUE
         PMAX = PMXTRL
  340    NFREF = NFREF + 1
         IF (NFREF.GE.ITMIN) GO TO 380
  360 CONTINUE
C
C     THE PROCESS HAS NOT SUCCEEDED IN REDUCING ALL THE
C     PERFORMANCE INDICES TO LESS THAN UNITY
C
      IERROR = 1
      IT = ITMAX
C
C     NUMBER OF ITERATIONS ACTUALLY TAKEN
C
  380 NIT = IT
      IF ( .NOT. WITHQ0) GO TO 440
C
C     IN THE CASE OF  Q0(X),  SCALE ITS COEFFICIENTS BY
C     AN INTEGRAL POWER OF  16  SUCH THAT THE LARGEST
C     COEFFICIENT IS OF ORDER UNITY
C
      AMAX = ZERO
      DO 400 I = 1, NP1
         IF (ABS(A(I)).GT.AMAX) AMAX = ABS(A(I))
  400 CONTINUE
      IF (AMAX.EQ.ZERO) GO TO 440
      I = LOG(AMAX)/LOG(SXTEEN)
      SCALE = SXTEEN**(-I)
      DO 420 I = 1, NP1
         A(I) = SCALE*A(I)
  420 CONTINUE
C
C     RETURN RESIDUALS CORRESPONDING TO SELECTED COEFFICIENTS
C
  440 WITHPI = .TRUE.
      CALL E01AEV(WITHQ0,WITHPI,M,XMIN,XMAX,X,N,Y,IP,IMAX,A,LA,IT,RNM,
     *            RTRLNM,IMPROV,ADIF,RES,PMAX,PINDEX)
      IFAIL = IERROR
      RETURN
C
C     END E01AEY
C
      END

      SUBROUTINE E01AEZ(M,XMIN,XMAX,X,Y,IP,N,A,LOCX,LOCY,FTAU,D,C)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     *******************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE QPOLY
C
C     CREATED 02 05 80.  UPDATED 14 05 80.  RELEASE 00/09
C
C     AUTHORS ... GERALD T. ANTHONY, MAURICE G. COX
C                 J. GEOFFREY HAYES AND MICHAEL A. SINGER.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     *******************************************************
C
C     E01AEZ. AN ALGORITHM TO DETERMINE THE CHEBYSHEV SERIES
C     REPRESENTATION OF A POLYNOMIAL INTERPOLANT  Q(X)  TO
C     ARBITRARY DATA POINTS WHERE DERIVATIVE INFORMATION MAY
C     BE GIVEN.
C
C     INPUT PARAMETERS
C        M        NUMBER OF DISTINCT X-VALUES.
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C        X        INDEPENDENT VARIABLE VALUES,
C                    NORMALIZED TO  (-1, 1)
C        Y        VALUES AND DERIVATIVES OF DEPENDENT VARIABLE
C        IP       HIGHEST ORDER OF DERIVATIVE AT EACH X-VALUE
C        N        NUMBER OF INTERPOLATING CONDITIONS.
C                    N = M + IP(1) + IP(2) + ... + IP(M).
C
C     OUTPUT PARAMETERS
C        A        CHEBYSHEV COEFFICIENTS OF  Q(X)
C
C     WORKSPACE PARAMETERS
C        LOCX     POINTERS TO X-VALUES IN CONSTRUCTING
C                    NEWTON FORM OF POLYNOMIAL
C        LOCY     POINTERS TO Y-VALUES CORRESPONDING TO X-VALUES
C        FTAU     SCALED VALUES OF  Y.  IF  Y(I)  IS THE
C                    VALUE OF AN  R-TH  DERIVATIVE, THEN
C                    ((XMAX - XMIN)/2)**R/(FACTORIAL R)
C                    TIMES  Y(I)  IS THE VALUE OF  FTAU(I)
C        D        INTERMEDIATE DIVIDED DIFFERENCE VALUES
C        C        NEWTON COEFFICIENTS OF  Q(X)
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(N), C(N), D(N), FTAU(N), X(M), Y(N)
      INTEGER           IP(M), LOCX(M), LOCY(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  CMIN, CNEW, FACTOR, ONE, PI, RI, RJ, S, SCALE,
     *                  SFAC, TWO, V, XCH, ZERO
      INTEGER           I, I2, IC, ICMIN, IFAIL, IFTAU, IP1, ISAVE, IY,
     *                  J, JMAX, K, KREV, L, LMAX, LOCXI, LOCXJ, LOCXK,
     *                  LOCYI, NC
C     .. External Functions ..
      DOUBLE PRECISION  X01AAF
      EXTERNAL          X01AAF
C     .. External Subroutines ..
      EXTERNAL          E01AEX, E02AFF
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SIN
C     .. Data statements ..
      DATA              ZERO, ONE, TWO/0.0D+0, 1.0D+0, 2.0D+0/
C     .. Executable Statements ..
      PI = X01AAF(ZERO)
      SCALE = (XMAX-XMIN)/TWO
C
C     INITIALIZE X- AND Y-POINTERS
C
      IY = 0
      DO 40 I = 1, M
         LOCX(I) = I
         IY = IY + 1
         LOCY(I) = IY
         FTAU(IY) = Y(IY)
         JMAX = IP(I)
         IF (JMAX.EQ.0) GO TO 40
C
C        FORM THE SCALED DERIVATIVES, I.E. AN  R-TH  DERIVATIVE
C        VALUE IS DIVIDED BY  FACTORIAL R  AND MULTIPLIED
C        BY THE  R-TH  POWER OF  (XMAX - XMIN)/2
C
         SFAC = ONE
         DO 20 J = 1, JMAX
            IY = IY + 1
            RJ = J
            SFAC = SFAC*SCALE/RJ
            FTAU(IY) = Y(IY)*SFAC
   20    CONTINUE
   40 CONTINUE
C
C     FORM SUCCESSIVE UPWARD SLOPING DIAGONALS OF
C     THE DIVIDED DIFFERENCE TABLE
C
      NC = 0
      DO 120 J = 1, M
C
C        CHOOSE EACH X-VALUE IN TURN TO MAKE THE CORRESPONDING
C        NEWTON COEFFICIENT AS SMALL IN MAGNITUDE AS POSSIBLE
C
         DO 80 I = J, M
            LOCXI = LOCX(I)
            LOCYI = LOCY(LOCXI)
            CALL E01AEX(M,X,IP,N,LOCX,C,NC,X(LOCXI),J,FTAU(LOCYI)
     *                  ,1,CNEW,D)
            IF (I.EQ.J) GO TO 60
            IF (ABS(CNEW).GE.ABS(CMIN)) GO TO 80
   60       CMIN = CNEW
            ICMIN = I
   80    CONTINUE
         C(NC+1) = CMIN
         ISAVE = LOCX(J)
         LOCXJ = LOCX(ICMIN)
         LOCX(ICMIN) = ISAVE
         LOCX(J) = LOCXJ
C
C        CALCULATE THE RESULTING NEWTON COEFFICIENT (I.E.
C        REPEAT THE ABOVE COMPUTATION, BUT ONLY IN THE CASE
C        LEADING TO THE SMALLEST NEW COEFFICIENT)
C
         IFTAU = LOCY(LOCXJ) - 1
         IP1 = IP(LOCXJ) + 1
         DO 100 I = 1, IP1
            IFTAU = IFTAU + 1
            CALL E01AEX(M,X,IP,N,LOCX,C,NC,X(LOCXJ),J,FTAU(IFTAU)
     *                  ,I,C(NC+1),D)
            NC = NC + 1
            IF (NC.EQ.N) GO TO 140
  100    CONTINUE
  120 CONTINUE
C
C     EVALUATE  Q(X)  (FROM ITS NEWTON FORM) AT THE EXTREMA
C     OF THE CHEBYSHEV POLYNOMIAL OF DEGREE  N - 1  ...
C
  140 FACTOR = 2*N - 2
      FACTOR = PI/FACTOR
      I2 = N + 1
      DO 200 I = 1, N
         I2 = I2 - 2
         RI = I2
         XCH = SIN(FACTOR*RI)
         S = C(N)
         IC = N
         K = M + 1
         DO 180 KREV = 1, M
            K = K - 1
            LOCXK = LOCX(K)
            LMAX = IP(LOCXK) + 1
            IF (K.EQ.M) LMAX = LMAX - 1
            IF (LMAX.LE.0) GO TO 180
            V = XCH - X(LOCXK)
            DO 160 L = 1, LMAX
               IC = IC - 1
               S = S*V + C(IC)
  160       CONTINUE
  180    CONTINUE
         D(I) = S
  200 CONTINUE
C
C     ... IN ORDER TO DETERMINE THE COEFFICIENTS IN ITS
C     CHEBYSHEV REPRESENTATION
C
      CALL E02AFF(N,D,A,IFAIL)
      RETURN
C
C     END E01AEZ
C
      END
      SUBROUTINE E01BAF(M,X,Y,K,C,LCK,WRK,LWRK,IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     ******************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE SP3INT
C
C     CREATED 16/5/79.                        RELEASE 00/00
C
C     AUTHORS ... GERALD T. ANTHONY, MAURICE G.COX
C                 J.GEOFFREY HAYES AND MICHAEL A. SINGER.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND
C
C     ******************************************************
C
C     E01BAF.  AN ALGORITHM, WITH CHECKS, TO DETERMINE THE
C     COEFFICIENTS IN THE B-SPLINE REPRESENTATION OF A CUBIC
C     SPLINE WHICH INTERPOLATES (PASSES EXACTLY THROUGH) A
C     GIVEN SET OF POINTS.
C
C     INPUT PARAMETERS
C        M        THE NUMBER OF DISTINCT POINTS WHICH THE
C                    SPLINE IS TO INTERPOLATE.
C                    (M MUST BE AT LEAST 4.)
C        X        ARRAY CONTAINING THE DISTINCT VALUES OF THE
C                    INDEPENDENT VARIABLE. NB X(I) MUST BE
C                    STRICTLY GREATER THAN X(J) WHENEVER I IS
C                    STRICTLY GREATER THAN J.
C        Y        ARRAY CONTAINING THE VALUES OF THE DEPENDENT
C                    VARIABLE.
C        LCK      THE SMALLER OF THE ACTUALLY DECLARED DIMENSIONS
C                    OF K AND C. MUST BE AT LEAST M + 4.
C
C     OUTPUT PARAMETERS
C        K        ON SUCCESSFUL EXIT, K CONTAINS THE KNOTS
C                    SET UP BY THE ROUTINE. IF THE SPLINE IS
C                    TO BE EVALUATED (BY NPL ROUTINE E02BEF,
C                    FOR EXAMPLE) THE ARRAY K MUST NOT BE
C                    ALTERED BEFORE CALLING THAT ROUTINE.
C        C        ON SUCCESSFUL EXIT, C CONTAINS THE B-SPLINE
C                    COEFFICIENTS OF THE INTERPOLATING SPLINE.
C                    THESE ARE ALSO REQUIRED BY THE EVALUATING
C                    ROUTINE E02BEF.
C        IFAIL    FAILURE INDICATOR
C                    0 - SUCCESSFUL TERMINATION.
C                    1 - ONE OF THE FOLLOWING CONDITIONS HAS
C                        BEEN VIOLATED -
C                        M AT LEAST 4
C                        LK AT LEAST M + 4
C                        LWORK AT LEAST 6 * M + 16
C                    2 - THE VALUES OF THE INDEPENDENT VARIABLE
C                        ARE DISORDERED. IN OTHER WORDS, THE
C                        CONDITION MENTIONED UNDER X IS NOT
C                        SATISFIED.
C
C     WORKSPACE (AND ASSOCIATED DIMENSION) PARAMETERS
C        WRK     WORKSPACE ARRAY, OF LENGTH LWRK.
C        LWRK    ACTUAL DECLARED DIMENSION OF WRK.
C                    MUST BE AT LEAST 6 * M + 16.
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E01BAF')
C     .. Scalar Arguments ..
      INTEGER           IFAIL, LCK, LWRK, M
C     .. Array Arguments ..
      DOUBLE PRECISION  C(LCK), K(LCK), WRK(LWRK), X(M), Y(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  ONE, SS
      INTEGER           I, IERROR, M1, M2
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          E02BAF
C     .. Data statements ..
      DATA              ONE/1.0D+0/
C     .. Executable Statements ..
      IERROR = 1
C
C     TESTS FOR ADEQUACY OF ARRAY LENGTHS AND THAT M IS GREATER
C     THAN 4.
C
      IF (LWRK.LT.6*M+16 .OR. M.LT.4) GO TO 80
      IF (LCK.LT.M+4) GO TO 80
C
C     TESTS FOR THE CORRECT ORDERING OF THE X(I)
C
      IERROR = 2
      DO 20 I = 2, M
         IF (X(I).LE.X(I-1)) GO TO 80
   20 CONTINUE
C
C     INITIALISE THE ARRAY OF KNOTS AND THE ARRAY OF WEIGHTS
C
      WRK(1) = ONE
      WRK(2) = ONE
      WRK(3) = ONE
      WRK(4) = ONE
      IF (M.EQ.4) GO TO 60
      DO 40 I = 5, M
         K(I) = X(I-2)
         WRK(I) = ONE
   40 CONTINUE
   60 M1 = M + 1
      M2 = M1 + M
C
C     CALL THE SPLINE FITTING ROUTINE
C
      IERROR = 0
      CALL E02BAF(M,M+4,X,Y,WRK,K,WRK(M1),WRK(M2),C,SS,IERROR)
C
C     ALL THE TESTS PERFORMED BY E02BAF ARE REDUNDANT
C     BECAUSE OF THE ABOVE TESTS AND ASSIGNMENTS, AND SO
C     IERROR = 0 AFTER THIS CALL.
C
   80 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
C
C     END OF E01BAF.
C
      END
      SUBROUTINE E01DAF(MX,MY,X,Y,F,PX,PY,LAMDA,MU,C,WRK,IFAIL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     Derived from DASL routine B2IRE.
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E01DAF')
      DOUBLE PRECISION  ONE
      PARAMETER         (ONE=1.0D+0)
C     .. Scalar Arguments ..
      INTEGER           IFAIL, MX, MY, PX, PY
C     .. Array Arguments ..
      DOUBLE PRECISION  C(MX*MY), F(MX*MY), LAMDA(MX+4), MU(MY+4),
     *                  WRK((MX+6)*(MY+6)), X(MX), Y(MY)
C     .. Local Scalars ..
      INTEGER           IDUM1, IDUM2, IE, IER2, IERR, IWGHT, IWRK,
     *                  IXKNOT, IXROW, IXU, IYKNOT, IYROW, IYU, JERROR,
     *                  LWRK, MDIST, NE, NREC, NXKNTS, NXU, NYKNTS, NYU
C     .. Local Arrays ..
      CHARACTER*80      REC(2)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          E01DAX, E01DAY, E01DAZ
C     .. Executable Statements ..
      IERR = 0
      NREC = 0
      IF (MX.LT.4) THEN
         IERR = 1
         NREC = 1
         WRITE (REC,FMT=99999) MX
      ELSE IF (MY.LT.4) THEN
         IERR = 1
         NREC = 1
         WRITE (REC,FMT=99998) MY
      ELSE
C        Numbers of interior X- and Y-knots.
         NXKNTS = MX - 4
         NYKNTS = MY - 4
C        Number of elements within intermediate coefficient matrix E.
         NE = MX*MY
C        Numbers of elements within bands of band upper triangular
C        matrices XUFCTR and YUFCTR.
         NXU = 2*(MX+NXKNTS+1)
         NYU = 2*(MY+NYKNTS+1)
C        Subdivide workspace.
         IE = 1
         IXU = IE + NE
         IYU = IXU + NXU
         IXKNOT = IYU + NYU
         IYKNOT = IXKNOT + 8
         IXROW = IYKNOT + 8
         IYROW = IXROW + MX
         IWRK = IYROW + MY
C        Check endpoints and X- and Y-values.
         MDIST = 0
         IWGHT = 1
         WRK(IWGHT) = ONE
         CALL E01DAX(X(1),X(MX),MX,X,WRK(IWGHT),0,1,IDUM1,IDUM2,MDIST,
     *               JERROR)
         IF (JERROR.EQ.0 .AND. MDIST.EQ.MX) THEN
            CALL E01DAX(Y(1),Y(MY),MY,Y,WRK(IWGHT),0,1,IDUM1,IDUM2,
     *                  MDIST,JERROR)
            IF (JERROR.EQ.0 .AND. MDIST.EQ.MY) THEN
C              Place X- and Y-knotlines.
               CALL E01DAY(4,NXKNTS,MX,X,WRK(IWGHT),0,1,1,MX,LAMDA(5),
     *                     MX)
               CALL E01DAY(4,NYKNTS,MY,Y,WRK(IWGHT),0,1,1,MY,MU(5),MY)
C              Construct spline interpolant.
               LWRK = (MX+6)*(MY+6)
               CALL E01DAZ(4,NXKNTS,X(1),X(MX),4,NYKNTS,Y(1),Y(MY),MX,X,
     *                     MY,Y,F,MY,1,MY*MX,LAMDA(5),MX,MU(5),MY,C,MY,
     *                     1,MY*MX,WRK(IXU),NXU,WRK(IYU),NYU,WRK(IE),1,
     *                     MX,NE,WRK(IXKNOT),8,WRK(IYKNOT),8,WRK(IXROW),
     *                     MX,WRK(IYROW),MY,WRK(IWRK),LWRK-IWRK+1,IER2)
C              Indicate whether system is numerically singular.
               IF (IER2.NE.0) THEN
                  IERR = 3
                  NREC = 2
                  WRITE (REC,FMT=99996)
               END IF
            ELSE
               IERR = 2
               NREC = 1
               WRITE (REC,FMT=99997)
            END IF
         ELSE
            IERR = 2
            NREC = 1
            WRITE (REC,FMT=99997)
         END IF
         IF (IERR.EQ.0) THEN
C           Insert exterior knots into LAMDA and MU.
            LAMDA(1) = X(1)
            LAMDA(2) = X(1)
            LAMDA(3) = X(1)
            LAMDA(4) = X(1)
            LAMDA(MX+1) = X(MX)
            LAMDA(MX+2) = X(MX)
            LAMDA(MX+3) = X(MX)
            LAMDA(MX+4) = X(MX)
            MU(1) = Y(1)
            MU(2) = Y(1)
            MU(3) = Y(1)
            MU(4) = Y(1)
            MU(MY+1) = Y(MY)
            MU(MY+2) = Y(MY)
            MU(MY+3) = Y(MY)
            MU(MY+4) = Y(MY)
C           Return the number of knots in X and Y directions, PX and PY.
            PX = MX + 4
            PY = MY + 4
         END IF
      END IF
C
      IFAIL = P01ABF(IFAIL,IERR,SRNAME,NREC,REC)
C
      RETURN
C
99999 FORMAT (1X,'** On entry, MX.lt.4: MX =',I16)
99998 FORMAT (1X,'** On entry, MY.lt.4: MY =',I16)
99997 FORMAT (1X,'** On entry, the X or the Y mesh points are not in s',
     *       'trictly ascending order.')
99996 FORMAT (1X,'** An intermediate set of linear equations is singul',
     *       'ar',/4X,'- the data is too ill-conditioned to compute B-',
     *       'spline coefficients.')
      END
      SUBROUTINE E01DAL(N,IBANDW,UFCTR,LUFCTR,NSETS,NTZERO,THETA,IT1,
     *                  IT2,LTHETA)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE RBSOL     SOLVE BAND UPPER TRIANGULAR
C     ================     SYSTEM (ROW STORAGE).
C
C     CREATED 25 10 78.  UPDATED 23 06 82.  RELEASE 00/06
C
C     AUTHORS ... MAURICE G. COX AND PAULINE E. M. CURTIS.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1978-1982
C
C     **********************************************************
C
C     RBSOL.  SOLVES  U*BETA = THETA,  WHERE  U  IS BAND
C     UPPER TRIANGULAR, BY BACK-SUBSTITUTION.  IF THE
C     LAST  NTZERO  COMPONENTS OF EACH VECTOR IN  THETA  ARE
C     ZERO, THEN SO ARE THE CORRESPONDING COMPONENTS
C     IN  BETA.  ADVANTAGE IS TAKEN OF THIS PROPERTY IN
C     THE SOLUTION PROCESS.
C
C     THESE ZERO COMPONENTS OF  THETA  DO NOT HAVE TO BE
C     PROVIDED, NEITHER ARE THE CORRESPONDING COMPONENTS
C     OF  BETA  RETURNED.
C
C     INPUT PARAMETERS
C        N        ORDER OF BAND UPPER TRIANGULAR MATRIX  U
C        IBANDW   BANDWIDTH OF  U
C        UFCTR    (BAND PART ONLY OF)  U,  STORED
C                    CONTIGUOUSLY IN ROW ORDER
C        LUFCTR   DIMENSION OF  UFCTR
C        NSETS    NUMBER OF RIGHT HAND SIDE VECTORS
C        NTZERO   NUMBER OF TRAILING COMPONENTS OF  THETA
C                    VECTORS TO BE REGARDED AS ZERO
C
C     INPUT/OUTPUT (AND ASSOCIATED) PARAMETERS
C        THETA    THETA  ON ENTRY,  BETA  ON EXIT
C        IT1,
C        IT2      INDEX INCREMENTS OF  THETA
C        LTHETA   DIMENSION OF  THETA
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      INTEGER           IBANDW, IT1, IT2, LTHETA, LUFCTR, N, NSETS,
     *                  NTZERO
C     .. Array Arguments ..
      DOUBLE PRECISION  THETA(LTHETA), UFCTR(LUFCTR)
C     .. Local Scalars ..
      DOUBLE PRECISION  S
      INTEGER           I, IB, IREV, ISET, IT, ITREF, IU, IU0, IU1,
     *                  JMAX, JREV, JREVMX, JTEST, Q
C     .. Executable Statements ..
C
      Q = N - NTZERO
      JTEST = N - IBANDW
      IU0 = -JTEST*(JTEST+1) - 2*N
      IU1 = 2*N + 1
      ITREF = 1 + (Q-1)*IT1 - IT2
C
C     DETERMINE EACH SOLUTION VECTOR IN TURN BY
C     BACK-SUBSTITUTION
C
      DO 80 ISET = 1, NSETS
         ITREF = ITREF + IT2
         IB = ITREF + IT1
         JMAX = Q
C
C        COMPUTE (IN REVERSE ORDER) THE FIRST  Q  COMPONENTS
C        OF THE  ISET-TH  SOLUTION VECTOR
C
         I = Q + 1
         DO 60 IREV = 1, Q
            I = I - 1
            IF (I+IBANDW.LE.Q) JMAX = JMAX - 1
            IB = IB - IT1
            S = THETA(IB)
C
C           DETERMINE STARTING LOCATION OF CONTRIBUTORY
C           ELEMENTS ... WHETHER IN MAIN PART OF BAND ...
C
            IF (I.LE.JTEST) IU = (IBANDW-1)*(I-1) + JMAX
C
C           ... OR IN BOTTOM RIGHT TRIANGLE OF ORDER  IBANDW
C
            IF (I.GT.JTEST) IU = (IU0+(IU1-I)*I)/2 + JMAX
            IT = ITREF - (Q-JMAX)*IT1
            IF (I.EQ.JMAX) GO TO 40
C
C           DETERMINE CONTRIBUTION TO  J-TH  COMPONENT
C           OF  ISET-TH  SOLUTION VECTOR
C
            JREVMX = JMAX - I
            DO 20 JREV = 1, JREVMX
               S = S - UFCTR(IU)*THETA(IT)
               IU = IU - 1
               IT = IT - IT1
   20       CONTINUE
   40       THETA(IT) = S/UFCTR(IU)
   60    CONTINUE
   80 CONTINUE
      RETURN
C
C     END E01DAL
C
      END
      SUBROUTINE E01DAM(NORDER,NKNOTS,XMIN,XMAX,LAMBDA,LLMBDA,JINTVL,
     *                  KNOT,LKNOT)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE KNTAS     ASSEMBLE KNOTS RELATING TO
C     ================     B-SPLINES THAT ARE NONZERO
C                          WITHIN SPECIFIED INTERVAL
C
C     CREATED 08 01 81.  UPDATED 23 06 82.  RELEASE 00/04
C
C     AUTHOR ... MAURICE G. COX.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1982
C
C     **********************************************************
C
C     KNTAS.  ASSEMBLES, FROM THE KNOT SET
C
C        ( L(1 - N), L(2 - N), ..., L(Q) ),
C
C     WHERE  N = NORDER,  Q = NKNOTS + NORDER,  AND
C
C              ( XMIN        (              J  .LT.  1     )
C     L(J)  =  ( LAMBDA(J)   (     1  .LE.  J  .LE.  NKNOTS)
C              ( XMAX        (NKNOTS  .LT.  J              )
C
C     THE CONTIGUOUS SUBSET
C
C        (KNOT(1), KNOT(2), ..., KNOT(2*NORDER))
C
C     WHICH RELATES TO THE B-SPLINES OF ORDER  NORDER  THAT
C     ARE NONZERO WITHIN INTERVAL NUMBER  JINTVL.
C
C     INPUT PARAMETERS
C        NORDER   ORDER (DEGREE + 1)
C        NKNOTS   NUMBER OF INTERIOR KNOTS
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C        LAMBDA   INTERIOR KNOTS
C        LLMBDA   DIMENSION OF  LAMBDA.  .GE. MAX(NKNOTS, 1)
C        JINTVL   INTERVAL NUMBER
C
C     OUTPUT (AND ASSOCIATED DIMENSION) PARAMETERS
C        KNOT     ASSEMBLED KNOT SET
C        LKNOT    DIMENSION OF  KNOT.  .GE.  2*NORDER.
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           JINTVL, LKNOT, LLMBDA, NKNOTS, NORDER
C     .. Array Arguments ..
      DOUBLE PRECISION  KNOT(LKNOT), LAMBDA(LLMBDA)
C     .. Local Scalars ..
      INTEGER           J, K, N2
C     .. Executable Statements ..
C
      N2 = 2*NORDER
      J = JINTVL - NORDER
      DO 20 K = 1, N2
         J = J + 1
         IF (J.LT.1) KNOT(K) = XMIN
         IF (J.GE.1 .AND. J.LE.NKNOTS) KNOT(K) = LAMBDA(J)
         IF (J.GT.NKNOTS) KNOT(K) = XMAX
   20 CONTINUE
      RETURN
C
C     END E01DAM
C
      END
      SUBROUTINE E01DAN(NKNOTS,LAMBDA,LLMBDA,X,JINTVL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE INTVL     INTERVAL SEARCH FOR THE SPLINE
C     ================     SUBINTERVAL CONTAINING  X
C
C     CREATED 13 06 79.  UPDATED 23 06 82.  RELEASE 00/05
C
C     AUTHORS ... DEREK BUSH, MAURICE G. COX, PAULINE E. M.
C                 CURTIS AND J. GEOFFREY HAYES
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX  TW11 0LW, ENGLAND
C
C     (C)  CROWN COPYRIGHT 1979-1982
C
C     **********************************************************
C
C     INTVL.  CALCULATES  JINTVL,  THE SPLINE
C     INTERVAL WITHIN WHICH  X  LIES.
C
C        JINTVL = 0       FOR  X .LT. LAMBDA(1),
C        JINTVL = NKNOTS  FOR LAMBDA(NKNOTS) .LE. X,
C        OTHERWISE  JINTVL  IS SUCH THAT
C           LAMBDA(JINTVL) .LE. X .LT. LAMBDA(JINTVL + 1).
C
C     INPUT PARAMETERS
C        NKNOTS   NUMBER OF INTERIOR KNOTS
C        LAMBDA   INTERIOR KNOTS
C        LLMBDA   DIMENSION OF LAMBDA
C        X        ABSCISSA VALUE
C
C     INPUT/OUTPUT PARAMETER
C        JINTVL   INTERVAL INDEX ASSOCIATED WITH  X
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X
      INTEGER           JINTVL, LLMBDA, NKNOTS
C     .. Array Arguments ..
      DOUBLE PRECISION  LAMBDA(LLMBDA)
C     .. Local Scalars ..
      INTEGER           JTEMP
C     .. External Subroutines ..
      EXTERNAL          E01DAP
C     .. Executable Statements ..
C
C     DISPENSE FIRST WITH THE CASES WHERE THERE ARE NO KNOTS,
C     WHERE  X .LT. LAMBDA(1),  WHERE  X .GE. LAMBDA(NKNOTS)
C
      JTEMP = 0
      IF (NKNOTS.EQ.0) GO TO 20
      IF (X.LT.LAMBDA(1)) GO TO 20
      JTEMP = NKNOTS
      IF (X.GE.LAMBDA(NKNOTS)) GO TO 20
      JTEMP = JINTVL
C
C     DETERMINE THE SPLINE SUBINTERVAL INDEX IN THE
C     GENERAL CASE
C
      IF (JTEMP.EQ.NKNOTS) JTEMP = NKNOTS - 1
      IF (JTEMP.EQ.0) JTEMP = 1
      IF ( .NOT. (LAMBDA(JTEMP).LE.X .AND. X.LT.LAMBDA(JTEMP+1)))
     *    CALL E01DAP(NKNOTS,LAMBDA,X,JTEMP)
   20 JINTVL = JTEMP
      RETURN
C
C     END E01DAN
C
      END
      SUBROUTINE E01DAP(NXDATA,XDATA,X,JINTVL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE INTVAL    DETERMINE THE INTERVAL INDEX
C     =================    JINTVL  ASSOCIATED WITH  X
C
C     CREATED 08 05 78.  UPDATED 21 06 82.  RELEASE 00/05
C
C     AUTHORS ... MAURICE G. COX, PAULINE E. M. CURTIS AND
C                 J. GEOFFREY HAYES
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX  TW11 0LW, ENGLAND
C
C     (C)  CROWN COPYRIGHT 1978-1982
C
C     **********************************************************
C
C     INTVAL.  DETERMINES THE INTERVAL INDEX  JINTVL  WITH
C     THE PROPERTY THAT
C        XDATA(JINTVL) .LE. X .LT. XDATA(JINTVL + 1)
C
C     INPUT PARAMETERS
C        NXDATA   NUMBER OF ABSCISSA VALUES
C        XDATA    ABSCISSA VALUES
C        X        ABSCISSA VALUE
C
C     INPUT/OUTPUT  PARAMETER
C        JINTVL   INTERVAL INDEX ASSOCIATED WITH  X
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X
      INTEGER           JINTVL, NXDATA
C     .. Array Arguments ..
      DOUBLE PRECISION  XDATA(NXDATA)
C     .. Local Scalars ..
      INTEGER           I, JMAX, JMIN, JTEMP, MXDATA, POWER
C     .. External Subroutines ..
      EXTERNAL          E01DAU
C     .. Executable Statements ..
C
C     INITIALIZE MAXIMUM AND MINIMUM VALUES FOR J
C
      JMAX = NXDATA
      JMIN = 1
      IF (X.GE.XDATA(JINTVL)) GO TO 60
C
C     HERE IF  X  IS LESS THAN  XDATA(JINTVL)  AND
C     GREATER THAN  XDATA(1)
C
      DO 20 I = 1, NXDATA
         IF (I.EQ.1) POWER = 1
         IF (I.GT.1) POWER = 2*POWER
         JTEMP = JINTVL - POWER
C
C        ENSURE THAT THE CURRENT VALUE FOR  JTEMP  IS
C        NOT OUT OF RANGE.
C
         IF (JTEMP.LT.1) JTEMP = 1
C
C        IF  X  IS LESS THAN THE CURRENT VALUE FOR
C        XDATA(JTEMP)  THEN REDUCE JTEMP
C
         IF (X.GE.XDATA(JTEMP)) GO TO 40
   20 CONTINUE
C
C     IT IS KNOWN THAT  X  IS NOT LESS THAN  XDATA(JTEMP)
C     AND THAT  X  IS LESS THAN  XDATA(JTEMP + 2**(R - 1))
C
   40 JMIN = JTEMP
      JMAX = JINTVL
      IF (POWER.GT.1) JMAX = JMIN + POWER/2
      GO TO 120
C
C     HERE IF  X  IS NOT LESS THAN  XDATA(JINTVL)  AND IS
C     LESS THAN  XDATA(NXDATA)
C
   60 DO 80 I = 1, NXDATA
         IF (I.EQ.1) POWER = 1
         IF (I.GT.1) POWER = 2*POWER
         JTEMP = JINTVL + POWER
C
C        ENSURE THAT THE CURRENT VALUE FOR  JTEMP  IS
C        NOT OUT OF RANGE.
C
         IF (JTEMP.GT.NXDATA) JTEMP = NXDATA
         IF (X.LT.XDATA(JTEMP)) GO TO 100
   80 CONTINUE
C
C     IT IS KNOWN THAT  X  IS NOT GREATER THAN  XDATA(JTEMP)
C     AND THAT  X  IS GREATER THAN
C     XDATA(JTEMP - 2**(R - 1))
C
  100 JMAX = JTEMP
      JMIN = JINTVL
      IF (POWER.GT.1) JMIN = JTEMP - POWER/2
C
C     BINARY SEARCH REQUIRES  MXDATA  KNOTS
C
  120 MXDATA = JMAX - JMIN + 1
C
C     LOOK FOR THE INTERVAL  JTEMP  CONTAINING THE GIVEN  X.
C     IT IS KNOWN THAT  XDATA(JMIN) .LE. X .LT. XDATA(JMAX).
C
      CALL E01DAU(MXDATA,XDATA(JMIN),X,JTEMP)
C
C     THE ROUTINE  E01DAU  GIVES A RELATIVE INTERVAL INDEX
C     BETWEEN  1  AND  JMAX - JMIN.  DETERMINE THE
C     ACTUAL INTERVAL INDEX.
C
      JINTVL = JTEMP + JMIN - 1
      RETURN
C
C     END E01DAP
C
      END
      SUBROUTINE E01DAQ(N,NSETS,NUFCTR,UFCTR,LUFCTR,THETA,IT1,IT2,
     *                  LTHETA,SFRSS,ISF1,LSFRSS,SRSS,ISR1,LSRSS)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name, and calls to
C     DASL routine VCONST replaced by functionally equivalent NAG.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE INITR     INITIALIZE UPPER TRIANGULAR
C     ================     MATRIX, RIGHT HAND SIDES AND
C                          RESIDUAL SUMS OF SQUARES
C
C     CREATED 18 07 78.  UPDATED 21 04 82.  RELEASE 00/04
C
C     AUTHORS ... MAURICE G. COX AND PAULINE E. M. CURTIS.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1978-1982
C
C     **********************************************************
C
C     INITR.  INITIALIZE TO ZERO AN UPPER TRIANGULAR MATRIX,
C     UFCTR, AND A SET OF RIGHT HAND SIDES, WITHIN THE
C     RECTANGULAR DATA STRUCTURE  THETA.  ALSO INITIALIZE
C     RESIDUAL SUMS OF SQUARES TO ZERO, BY SETTING SCALED
C     RESIDUAL SUMS OF SQUARES, SRSS, TO UNITY, AND SCALE
C     FACTORS, SFRSS, FOR RESIDUAL SUMS OF SQUARES, TO ZERO.
C
C     INPUT PARAMETERS
C        N        ORDER OF UPPER TRIANGULAR MATRIX  UFCTR
C        NSETS    NUMBER OF RIGHT HAND SIDES
C        NUFCTR   NUMBER OF ELEMENTS OF  UFCTR  TO BE
C                    INITIALIZED
C
C     OUTPUT (AND ASSOCIATED) PARAMETERS
C        UFCTR    UPPER TRIANGULAR MATRIX
C        LUFCTR   DIMENSION OF  UFCTR
C        THETA    RIGHT HAND SIDE VECTORS
C        IT1,
C        IT2      INDEX INCREMENTS OF  THETA
C        LTHETA   DIMENSION OF  THETA
C        SFRSS    SCALE FACTORS FOR RESIDUAL SUMS OF SQUARES
C        ISF1     INDEX INCREMENT OF  SFRSS
C        LSFRSS   DIMENSION OF  SFRSS
C        SRSS     SCALED RESIDUAL SUMS OF SQUARES
C        ISR1     INDEX INCREMENT OF  SRSS
C        LSRSS    DIMENSION OF  SRSS
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      INTEGER           ISF1, ISR1, IT1, IT2, LSFRSS, LSRSS, LTHETA,
     *                  LUFCTR, N, NSETS, NUFCTR
C     .. Array Arguments ..
      DOUBLE PRECISION  SFRSS(LSFRSS), SRSS(LSRSS), THETA(LTHETA),
     *                  UFCTR(LUFCTR)
C     .. Local Scalars ..
      DOUBLE PRECISION  ONE, ZERO
      INTEGER           ISET, ITREF
C     .. External Subroutines ..
      EXTERNAL          F06FBF
C     .. Data statements ..
C
      DATA              ZERO, ONE/0.0D+0, 1.0D+0/
C     .. Executable Statements ..
C
C     INITIALIZE UPPER TRIANGULAR FACTOR
C
C      CALL VCONST ( ZERO, NUFCTR, UFCTR, 1, LUFCTR )
C      Replace call to DASL VCONST above by call to Nag F06FBF.
      CALL F06FBF(NUFCTR,ZERO,UFCTR,1)
      IF (NSETS.LE.0) GO TO 40
C
C     INITIALIZE RIGHT HAND SIDE VECTORS
C
      ITREF = 1 - IT2
      DO 20 ISET = 1, NSETS
         ITREF = ITREF + IT2
C         CALL VCONST ( ZERO, N, THETA(ITREF),
C        *                 IT1, LTHETA - ITREF + 1 )
         CALL F06FBF(N,ZERO,THETA(ITREF),IT1)
   20 CONTINUE
C
C     INITIALIZE RESIDUAL SUMS OF SQUARES
C
C      CALL VCONST ( ZERO, NSETS, SFRSS, ISF1, LSFRSS )
      CALL F06FBF(NSETS,ZERO,SFRSS,ISF1)
C      CALL VCONST ( ONE, NSETS, SRSS, ISR1, LSRSS )
      CALL F06FBF(NSETS,ONE,SRSS,ISR1)
   40 CONTINUE
      RETURN
C
C     END E01DAQ
C
      END
      SUBROUTINE E01DAR(N,IBANDW,IXNZST,XROW,NSETS,YROW,IY1,LYROW,
     *                  LASTCL,UFCTR,LUFCTR,THETA,IT1,IT2,LTHETA,WRK,
     *                  LWRK)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name, and calls to
C     DASL routines VSCADD and VDCOPY replaced by functionally
C     equivalent NAG.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE ERB       ROW ELIMINATION FOR BAND UPPER
C     ==============       TRIANGULAR MATRIX STORED BY ROWS
C
C     CREATED 08 09 81.  UPDATED 24 06 82.  RELEASE 00/10
C
C     AUTHOR ... MAURICE G. COX.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1981-1982
C
C     **********************************************************
C
C     ERB.  UPDATES, USING ELIMINATION WITHOUT PIVOTING, A
C     BAND UPPER TRIANGULAR SYSTEM  (U, THETA)  BY ONE ROW
C     (XROW, YROW)
C
C     INPUT PARAMETERS
C        N        ORDER OF BAND UPPER TRIANGULAR MATRIX  U
C        IBANDW   BANDWIDTH OF  U
C        IXNZST   COLUMN POSITION OF FIRST NONZERO IN  XROW
C        XROW     OBSERVATIONAL ROW (BASIS FUNCTION VALUES)
C                    DESTROYED ON EXIT
C        NSETS    NUMBER OF RIGHT HAND SIDES (DEPENDENT
C                    VARIABLES)
C        YROW     OBSERVATIONAL ROW (DEPENDENT VARIABLE
C                    VALUES)
C        IY1      INDEX INCREMENT OF  YROW
C        LYROW    DIMENSION OF  YROW
C
C     INPUT/OUTPUT (AND ASSOCIATED) PARAMETERS
C        LASTCL   LAST COLUMN OF  UFCTR  CONTAINING
C                    NONZERO ELEMENTS
C        UFCTR    BAND UPPER TRIANGULAR MATRIX, STORED BY
C                    ROWS
C        LUFCTR   DIMENSION OF  UFCTR.
C                   .GE. IBANDW*(2*N - IBANDW + 1)/2
C        THETA    TRANSFORMED RIGHT HAND SIDE VECTORS
C        IT1,
C        IT2      INDEX INCREMENTS OF  THETA
C        LTHETA   DIMENSION OF  THETA
C
C     WORKSPACE (AND ASSOCIATED) PARAMETERS
C        WRK      WORKSPACE
C        LWRK     DIMENSION OF  WRK.  .GE. NSETS.
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      INTEGER           IBANDW, IT1, IT2, IXNZST, IY1, LASTCL, LTHETA,
     *                  LUFCTR, LWRK, LYROW, N, NSETS
C     .. Array Arguments ..
      DOUBLE PRECISION  THETA(LTHETA), UFCTR(LUFCTR), WRK(LWRK),
     *                  XROW(N), YROW(LYROW)
C     .. Local Scalars ..
      DOUBLE PRECISION  ONE, SCALE, ZERO
      INTEGER           IT, IU, IU0, IU1, J, NMBW
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Data statements ..
C
C     KEY LOCAL VARIABLES
C        IU0,
C        IU1      CONSTANTS IN FORMULA FOR  J-TH  DIAGONAL
C                    ELEMENT OF  UFCTR  (J .GT. N - IBANDW)
C        SCALE    NEGATED MULTIPLIER IN ELIMINATION STEP
C
      DATA              ZERO, ONE/0.0D+0, 1.0D+0/
C     .. Executable Statements ..
C
      NMBW = N - IBANDW
      IU0 = -NMBW**2 - 3*N + IBANDW
      IU1 = 2*N + 3
      LASTCL = MAX(LASTCL,MIN(IXNZST+IBANDW-1,N))
C
C     COPY  YROW  TO  WRK
C
C      CALL VDCOPY ( NSETS, YROW, IY1, LYROW, ONE,
C     *              WRK, 1, LWRK )
C     Replace call to DASL routine VDCOPY above by BLAS DCOPY.
      CALL DCOPY(NSETS,YROW,IY1,WRK,1)
C
C     ANNIHILATE SUCCESSIVELY ELEMENTS  IXNZST  TO  LASTCL
C
      DO 40 J = IXNZST, LASTCL
         IF (XROW(J).EQ.ZERO) GO TO 40
         IT = 1 + (J-1)*IT1
C
C        INDEX OF DIAGONAL ELEMENT ON MAIN PART OF BAND ...
C
         IF (J.LE.NMBW) IU = IBANDW*(J-1) + 1
C
C        ... OR IN BOTTOM RIGHT TRIANGLE OF ORDER  IBANDW
C
         IF (J.GT.NMBW) IU = (IU0+(IU1-J)*J)/2
         IF (UFCTR(IU).NE.ZERO) GO TO 20
C
C           TRANSFER STEP
C
C            CALL VDCOPY ( LASTCL - J + 1, XROW(J),
C        *                    1, N - J + 1, ONE, UFCTR(IU),
C        *                    1, LUFCTR - IU + 1 )
C        Replace call to DASL routine VDCOPY above by BLAS DCOPY.
         CALL DCOPY(LASTCL-J+1,XROW(J),1,UFCTR(IU),1)
C            CALL VDCOPY ( NSETS, WRK, 1, LWRK, ONE,
C        *                    THETA(IT), IT2, LTHETA - IT + 1 )
C        Replace call to DASL routine VDCOPY above by BLAS DCOPY.
         CALL DCOPY(NSETS,WRK,1,THETA(IT),IT2)
         GO TO 60
C
C           ELIMINATION STEP
C
   20    SCALE = -XROW(J)/UFCTR(IU)
C            CALL VSCADD ( SCALE,
C        *                    MIN0 ( IBANDW, LASTCL - J + 1 ),
C        *                    UFCTR(IU), 1, LUFCTR - IU + 1,
C        *                    XROW(J), 1, N - J + 1 )
C           Replace DASL routine VSCADD call above by BLAS DAXPY.
         CALL DAXPY(MIN(IBANDW,LASTCL-J+1),SCALE,UFCTR(IU),1,XROW(J),1)
C            CALL VSCADD ( SCALE, NSETS, THETA(IT), IT2,
C        *                    LTHETA - IT2 + 1, WRK, 1, LWRK )
C        Replace DASL routine VSCADD call above by BLAS DAXPY.
         CALL DAXPY(NSETS,SCALE,THETA(IT),IT2,WRK,1)
   40 CONTINUE
   60 RETURN
C
C     END E01DAR
C
      END
      SUBROUTINE E01DAS(N,IBANDW,UFCTR,LUFCTR,IFAIL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE CHKRB     CHECK INVERTIBILITY OF BAND
C     ================     UPPER TRIANGULAR MATRIX.
C
C     CREATED 07 07 80.  UPDATED 24 06 82.  RELEASE 00/06
C
C     AUTHORS ... MAURICE G. COX AND PAULINE E. M. CURTIS.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1980-1982
C
C     **********************************************************
C
C     CHKRB.  AN ALGORITHM FOR DETERMINING WHETHER A BAND
C     UPPER TRIANGULAR MATRIX IS INVERTIBLE
C     BY EXAMINING ITS DIAGONAL ELEMENTS.
C
C     INPUT PARAMETERS
C        N        ORDER OF BAND UPPER TRIANGULAR MATRIX
C        IBANDW   BANDWIDTH OF BAND UPPER TRIANGULAR MATRIX
C        UFCTR    (BAND PART ONLY OF) BAND UPPER TRIANGULAR
C                    MATRIX, STORED CONTIGUOUSLY IN ROW
C                    ORDER
C        LUFCTR   DIMENSION OF  UFCTR
C
C     FAILURE INDICATOR PARAMETER
C        IFAIL    FAILURE INDICATOR
C                    1 - ONE OF THE DIAGONAL ELEMENTS OF
C                        UFCTR  IS ZERO
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      INTEGER           IBANDW, IFAIL, LUFCTR, N
C     .. Array Arguments ..
      DOUBLE PRECISION  UFCTR(LUFCTR)
C     .. Local Scalars ..
      DOUBLE PRECISION  ZERO
      INTEGER           IERROR, IU, J, JTEST, NP2
C     .. Intrinsic Functions ..
      INTRINSIC         MIN
C     .. Data statements ..
C
      DATA              ZERO/0.0D+0/
C     .. Executable Statements ..
C
      IERROR = 1
      NP2 = N + 2
      JTEST = NP2 - IBANDW
      IU = 1 - MIN(IBANDW,N+1)
      DO 20 J = 1, N
         IF (J.LE.JTEST) IU = IU + IBANDW
         IF (J.GT.JTEST) IU = IU + NP2 - J
         IF (UFCTR(IU).EQ.ZERO) GO TO 40
   20 CONTINUE
      IERROR = 0
   40 IFAIL = IERROR
      RETURN
C
C     END E01DAS
C
      END
      SUBROUTINE E01DAT(NORDER,KNOT,LKNOT,X,BASIS)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE BRV       ONE MAJOR STEP OF BASIC 3-TERM
C     ==============       B-SPLINE RECURRENCE RELATION
C
C     CREATED 08 01 81.  UPDATED 21 06 82.  RELEASE 00/08
C
C     AUTHOR ... MAURICE G. COX.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1981-1982
C
C     **********************************************************
C
C     BRV.  GIVEN THE  NORDER - 1  VALUES AT  X  OF THE
C     NORMALIZED B-SPLINES OF ORDER  NORDER - 1  WHICH ARE
C     NONZERO IN THE KNOT INTERVAL CONTAINING  X,  BRV
C     DETERMINES THE  NORDER  VALUES AT  X  OF THE
C     NORMALIZED B-SPLINES OF ORDER  NORDER
C     WHICH ARE NONZERO IN THIS INTERVAL.
C
C     INPUT PARAMETERS
C        NORDER   ORDER (DEGREE + 1)
C        KNOT     KNOTS RELATING TO B-SPLINES OF ORDER
C                    NORDER  THAT ARE NONZERO IN THE
C                    INTERVAL CONTAINING  X,  I.E. THE
C                    NORDER  KNOTS TO THE IMMEDIATE LEFT AND
C                    THE  NORDER  KNOTS TO THE IMMEDIATE
C                    RIGHT OF  X
C        LKNOT    DIMENSION OF  KNOT.  .GE.  2*NORDER.
C        X        ABSCISSA VALUE
C
C     INPUT/OUTPUT PARAMETERS
C        BASIS    NONZERO B-SPLINE BASIS VALUES.
C                    NORDER - 1  VALUES ON ENTRY,
C                    NORDER      VALUES ON EXIT.
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X
      INTEGER           LKNOT, NORDER
C     .. Array Arguments ..
      DOUBLE PRECISION  BASIS(NORDER), KNOT(LKNOT)
C     .. Local Scalars ..
      DOUBLE PRECISION  BNOW, BPREV, ONE, ZERO
      INTEGER           I, KL, KR
C     .. Data statements ..
C
      DATA              ZERO, ONE/0.0D+0, 1.0D+0/
C     .. Executable Statements ..
C
C     BASIS OF ORDER UNITY
C
      IF (NORDER.EQ.1) BASIS(1) = ONE
      IF (NORDER.EQ.1) GO TO 60
C
C        BASIS OF ORDER GREATER THAN ONE
C
   20 KL = NORDER + 1
      KR = 2*NORDER
      BNOW = ZERO
      DO 40 I = 2, NORDER
         KL = KL - 1
         KR = KR - 1
         BPREV = BNOW
         BNOW = BASIS(KL-1)/(KNOT(KR)-KNOT(KL))
         BASIS(KL) = (X-KNOT(KL))*BNOW + (KNOT(KR+1)-X)*BPREV
   40 CONTINUE
      BASIS(1) = (KNOT(NORDER+1)-X)*BNOW
   60 RETURN
C
C     END E01DAT
C
      END
      SUBROUTINE E01DAU(NXDATA,XDATA,X,J)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE BNSCH     BINARY SEARCH FOR INTERVAL INDEX
C     ================
C
C     CREATED 08 05 78.  UPDATED 21 06 82.  RELEASE 00/04
C
C     AUTHORS ... MAURICE G. COX, PAULINE E. M. CURTIS AND
C                 J. GEOFFREY HAYES
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX  TW11 0LW, ENGLAND
C
C     (C)  CROWN COPYRIGHT 1978-1982
C
C     **********************************************************
C
C     BNSCH.  BINARY SEARCH ROUTINE TO FIND THE INTERVAL
C     INDEX  J  SUCH THAT  XDATA(J) .LE. X .LT. XDATA(J + 1)
C
C     INPUT PARAMETERS
C        NXDATA   NUMBER OF ABSCISSA VALUES
C        XDATA    ABSCISSA VALUES
C        X        ABSCISSA VALUE
C
C     OUTPUT  PARAMETER
C        J        INTERVAL INDEX ASSOCIATED WITH  X
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X
      INTEGER           J, NXDATA
C     .. Array Arguments ..
      DOUBLE PRECISION  XDATA(NXDATA)
C     .. Local Scalars ..
      INTEGER           JHI, JLO, MIDDLE
      LOGICAL           BELOW
C     .. Executable Statements ..
C
C     INITIAL BOUNDS FOR  J
C
      JLO = 1
      JHI = NXDATA
C
C     BISECT CURRENT INTERVAL
C
   20 MIDDLE = (JLO+JHI)/2
C
C     TERMINATE SEARCH IF INTERVAL BETWEEN LOWER AND
C     UPPER BOUNDS IS SUFFICIENTLY SMALL
C
      IF (JHI-JLO.LE.1) GO TO 40
C
C     SET NEW BOUNDS
C
      BELOW = X .LT. XDATA(MIDDLE)
      IF (BELOW) JHI = MIDDLE
      IF ( .NOT. BELOW) JLO = MIDDLE
      GO TO 20
   40 J = JLO
      RETURN
C
C     END E01DAU
C
      END
      SUBROUTINE E01DAV(NORDER,KNOT,LKNOT,X,BASIS)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE BBV       EVALUATION OF B-SPLINE BASIS
C     ==============       FROM BASIC 3-TERM RECURRENCE
C                          RELATION
C
C     CREATED 09 01 81.  UPDATED 21 06 82.  RELEASE 00/07
C
C     AUTHORS ... MAURICE G. COX AND PAULINE E. M. CURTIS.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1981-1982
C
C     **********************************************************
C
C     BBV.  DETERMINES THE  NORDER  VALUES AT  X  OF THE
C     NORMALIZED B-SPLINES OF ORDER  NORDER  WHICH ARE
C     NONZERO IN THE KNOT INTERVAL CONTAINING  X.
C
C     INPUT PARAMETERS
C        NORDER   ORDER (DEGREE + 1)
C        KNOT     KNOTS RELATING TO B-SPLINES OF ORDER
C                    NORDER  THAT ARE NONZERO IN THE
C                    INTERVAL CONTAINING  X,  I.E. THE
C                    NORDER  KNOTS TO THE IMMEDIATE LEFT AND
C                    THE  NORDER  KNOTS TO THE IMMEDIATE
C                    RIGHT OF  X
C        LKNOT    DIMENSION OF  KNOT.  .GE.  2*NORDER.
C        X        ABSCISSA VALUE
C
C     OUTPUT PARAMETERS
C        BASIS    NONZERO B-SPLINE BASIS VALUES
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X
      INTEGER           LKNOT, NORDER
C     .. Array Arguments ..
      DOUBLE PRECISION  BASIS(NORDER), KNOT(LKNOT)
C     .. Local Scalars ..
      INTEGER           IKNOT, JORDER
C     .. External Subroutines ..
      EXTERNAL          E01DAT
C     .. Executable Statements ..
C
      IKNOT = NORDER + 1
      DO 20 JORDER = 1, NORDER
         IKNOT = IKNOT - 1
         CALL E01DAT(JORDER,KNOT(IKNOT),2*JORDER,X,BASIS)
   20 CONTINUE
      RETURN
C
C     END E01DAV
C
      END
      SUBROUTINE E01DAW(NORDER,XMIN,XMAX,M,X,NSETS,F,IF1,IF2,LF,NKNOTS,
     *                  LAMBDA,LLMBDA,C,IC1,IC2,LC,UFCTR,LUFCTR,KNOT,
     *                  LKNOT,XROW,LXROW,WRK,LWRK,IFAIL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name, and calls to
C     DASL routine VCONST replaced by functionally equivalent NAG,
C     and a call to E01DAQ modified slightly as explained below.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE B1I       POLYNOMIAL SPLINE INTERPOLANT
C     ==============       TO ARBITRARY DATA
C                          - BASE VERSION
C
C     CREATED 10 09 79.  UPDATED 24 06 82.  RELEASE 00/09
C
C     AUTHORS ... MAURICE G. COX AND PAULINE E. M. CURTIS.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1979-1982
C
C     **********************************************************
C
C     B1I.  DETERMINES UNIVARIATE POLYNOMIAL SPLINE
C     INTERPOLANTS IN THE FOLLOWING WAY.
C
C     (1)  INITIALIZE A BAND UPPER TRIANGULAR MATRIX  U
C          AND RIGHT HAND SIDE VECTORS  THETA  TO ZERO.
C
C     (2)  FOR EACH VALUE OF  I  FROM  1  TO  M
C
C          (2.1)  FORM IN  XROW  THE VALUES OF THE B-SPLINE
C                 BASIS FUNCTIONS AT  X(I).
C
C          (2.2)  UPDATE THE SYSTEM  (U, THETA)  TO INCLUDE
C                 THE OBSERVATION  (XROW, FROW),  WHERE
C                 FROW  DENOTES THE ROW VECTOR OF  NSETS
C                 ELEMENTS CONTAINING THE F-VALUES
C                 CORRESPONDING TO  X(I).
C
C     (3)  SOLVE THE RESULTING SYSTEM  U*C = THETA.
C
C     INPUT PARAMETERS
C        NORDER   ORDER (DEGREE + 1) OF SPLINE(S)  S
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C        M        NUMBER OF INDEPENDENT VARIABLE VALUES
C        X        INDEPENDENT VARIABLE VALUES
C        NSETS    NUMBER OF SPLINES
C        F        DEPENDENT VARIABLE VALUES
C        IF1,
C        IF2      INDEX INCREMENTS OF  F
C        LF       DIMENSION OF  F
C        NKNOTS   NUMBER OF INTERIOR KNOTS
C
C     OUTPUT (AND ASSOCIATED) PARAMETERS
C        LAMBDA   INTERIOR KNOTS
C        LLMBDA   DIMENSION OF  LAMBDA
C        C        B-SPLINE COEFFICIENTS OF  S
C        IC1,
C        IC2      INDEX INCREMENTS OF  C
C        LC       DIMENSION OF  C
C        UFCTR    BAND UPPER TRIANGULAR MATRIX  U,
C                    STORED BY ROWS
C        LUFCTR   DIMENSION OF  UFCTR.  .GE. NUFCTR =
C                    NORDER*(M + NKNOTS + 1)/2
C
C     WORKSPACE (AND ASSOCIATED DIMENSION) PARAMETERS
C        KNOT     KNOTS USED IN COMPUTING B-SPLINE BASIS
C                    FOR CURRENT X-VALUE
C        LKNOT    DIMENSION OF  KNOT.  .GE. 2*NORDER.
C        XROW     OBSERVATIONAL ROW CONTAINING B-SPLINE
C                    BASIS VALUES FOR CURRENT X-VALUE
C        LXROW    DIMENSION OF  XROW.  .GE. M.
C        WRK      REAL WORKSPACE REQUIRED BY  ERB
C        LWRK     DIMENSION OF  WRK.  .GE.  NSETS.
C
C     FAILURE INDICATOR PARAMETER
C        IFAIL    FAILURE INDICATOR
C                    1 - NUMERICALLY SINGULAR SYSTEM
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           IC1, IC2, IF1, IF2, IFAIL, LC, LF, LKNOT,
     *                  LLMBDA, LUFCTR, LWRK, LXROW, M, NKNOTS, NORDER,
     *                  NSETS
C     .. Array Arguments ..
      DOUBLE PRECISION  C(LC), F(LF), KNOT(LKNOT), LAMBDA(LLMBDA),
     *                  UFCTR(LUFCTR), WRK(LWRK), X(M), XROW(LXROW)
C     .. Local Scalars ..
      INTEGER           I, IERROR, IF, JINTVL, JNTVL0, LASTCL, NUFCTR
C     .. External Subroutines ..
      EXTERNAL          E01DAL, E01DAM, E01DAN, E01DAQ, E01DAR, E01DAS,
     *                  E01DAV
C     .. Executable Statements ..
C
C     NUMBER OF ELEMENTS WITHIN BAND OF  U
C
      NUFCTR = (NORDER*(M+NKNOTS+1))/2
C
C     INITIALIZE  U  AND RIGHT HAND SIDE VECTORS  THETA
C     (HELD IN LOCATIONS SUBSEQUENTLY TO BE OCCUPIED BY  C)
C
C      CALL E01DAQ ( M, NSETS, NUFCTR, UFCTR, LUFCTR, C, IC1,
C     *             IC2, LC, WRK(1), 0, 1, WRK(1), 0, 1 )
C
C     Call above modified to that below so that E01DAQ can call
C     NAG routine F06FBF instead of DASL routine VCONST.
C     ( E01DAQ calls VCONST with N = NSETS, IV1 = 0, LV = 1 . i.e
C     VCONST initialises element WRK(1), NSETS times. Making the
C     call to F06FBF instead initialises elements WRK(1)..WRK(NSETS)
C     one time each. This makes no difference since the results are
C     ignored anyway. )
C
      CALL E01DAQ(M,NSETS,NUFCTR,UFCTR,LUFCTR,C,IC1,IC2,LC,WRK(1),1,
     *            LWRK,WRK(1),1,LWRK)
C
C     INITIALIZE NUMBER OF RIGHTMOST COLUMN OF  U  THAT
C     CONTAINS NONZERO ELEMENTS
C
      LASTCL = 0
C
C     INITIALIZE INTERVAL NUMBER
C
      JINTVL = 0
C
C     INITIALIZE KNOTS
C
      CALL E01DAM(NORDER,NKNOTS,XMIN,XMAX,LAMBDA,LLMBDA,JINTVL,KNOT,
     *            LKNOT)
C
C     INITIALIZE ORDINATE INDEX
C
      IF = 1 - IF1
C
C     COUNT OVER DATA POINTS
C
      DO 20 I = 1, M
C
C        UPDATE ORDINATE INDEX
C
         IF = IF + IF1
C
C        PREVIOUS INTERVAL NUMBER
C
         JNTVL0 = JINTVL
C
C        NUMBER OF INTERVAL CONTAINING  X(I)
C
         CALL E01DAN(NKNOTS,LAMBDA,LLMBDA,X(I),JINTVL)
C
C        IF THE CURRENT DATA ABSCISSA LIES IN AN INTERVAL
C        DIFFERENT FROM THAT CONSIDERED PREVIOUSLY,
C        ASSEMBLE THE  2*NORDER  KNOTS THAT RELATE TO THE
C        B-SPLINES OF ORDER  NORDER  THAT ARE NONZERO IN
C        THE INTERVAL NUMBERED  JINTVL  CONTAINING  X(I)
C
         IF (JINTVL.NE.JNTVL0) CALL E01DAM(NORDER,NKNOTS,XMIN,XMAX,
     *                              LAMBDA,LLMBDA,JINTVL,KNOT,LKNOT)
C
C        FORM THE VALUES AT  X(I)  OF THE B-SPLINE BASIS
C        FUNCTIONS THAT ARE NONZERO WITHIN THIS INTERVAL
C        AND INSERT THEM INTO THE RELEVANT PART OF  XROW
C
         CALL E01DAV(NORDER,KNOT,LKNOT,X(I),XROW(JINTVL+1))
C
C        UPDATE  U, THETA  AND  LASTCL  (E01DAR  REQUIRES
C        WORKSPACE OF  NSETS  REAL ELEMENTS)
C
         CALL E01DAR(M,NORDER,JINTVL+1,XROW,NSETS,F(IF),IF2,LF-IF+1,
     *               LASTCL,UFCTR,LUFCTR,C,IC1,IC2,LC,WRK,LWRK)
   20 CONTINUE
C
C     CHECK THAT  U  IS NONSINGULAR
C
      CALL E01DAS(M,NORDER,UFCTR,LUFCTR,IERROR)
C
C     SOLVE  U*C = THETA
C
      IF (IERROR.EQ.0) CALL E01DAL(M,NORDER,UFCTR,LUFCTR,NSETS,0,C,IC1,
     *                             IC2,LC)
      IFAIL = IERROR
      RETURN
C
C     END E01DAW
C
      END
      SUBROUTINE E01DAX(XMIN,XMAX,M,X,W,IW1,LW,IFNZWT,MNZWT,MDNZWT,
     *                  IFAIL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE CHKWX     CHECK WEIGHT AND ABSCISSA ARRAYS
C     ================
C
C     CREATED 05 03 80.  UPDATED 23 04 82.  RELEASE 00/04
C
C     AUTHORS ... GERALD T. ANTHONY, MAURICE G. COX AND
C                 PAULINE E. M. CURTIS.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND
C
C     (C)  CROWN COPYRIGHT 1980-1982
C
C     **********************************************************
C
C     CHKWX.  CHECKS THAT THE X-VALUES OF DATA POINTS WITH
C     NONZERO WEIGHT ARE IN NONDECREASING ORDER AND LIE
C     IN THE CLOSED INTERVAL  XMIN  TO  XMAX.
C     THE INDEX OF THE FIRST DATA POINT WITH NONZERO
C     WEIGHT, THE NUMBER OF DATA POINTS WITH NONZERO
C     WEIGHTS AND THE NUMBER OF DISTINCT DATA POINTS WITH
C     NONZERO WEIGHTS ARE DETERMINED.
C
C     INPUT PARAMETERS
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C        M        NUMBER OF DATA VALUES
C        X        ABSCISSA VALUES
C        W        WEIGHTS (INVERSELY PROPORTIONAL TO
C                    ESTIMATED ERRORS IN F-VALUES)
C        IW1      INDEX INCREMENT OF  W
C        LW       DIMENSION OF  W
C
C     OUTPUT PARAMETERS
C        IFNZWT   INDEX OF FIRST DATA POINT WITH NONZERO
C                    WEIGHT
C        MNZWT    NUMBER OF DATA POINTS WITH NONZERO WEIGHT
C        MDNZWT   NUMBER OF DATA POINTS WITH DISTINCT
C                    ABSCISSA VALUES AND NONZERO WEIGHT
C                    (ONLY IF  IFAIL = 0)
C
C     FAILURE INDICATOR PARAMETER
C        IFAIL    FAILURE INDICATOR
C                    0 - SUCCESSFUL TERMINATION
C                    1 - AN X-VALUE WITH NONZERO WEIGHT
C                        LIES OUTSIDE THE CLOSED INTERVAL
C                        XMIN  TO  XMAX
C                    2 - THE X-VALUES WITH NONZERO WEIGHTS
C                        ARE NOT IN NONDECREASING ORDER
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           IFAIL, IFNZWT, IW1, LW, M, MDNZWT, MNZWT
C     .. Array Arguments ..
      DOUBLE PRECISION  W(LW), X(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  XPREV, ZERO
      INTEGER           IDNZWT, IERROR, INZWT, IW, R, RSTART
C     .. Data statements ..
C
      DATA              ZERO/0.0D+0/
C     .. Executable Statements ..
C
      IERROR = 0
      INZWT = 0
      IDNZWT = 0
C
C     DETERMINE THE INDEX  IFNZWT  OF THE FIRST DATA POINT
C     WITH NONZERO WEIGHT
C
      IW = 1 - IW1
      DO 20 R = 1, M
         IW = IW + IW1
         IF (W(IW).NE.ZERO) GO TO 40
   20 CONTINUE
      IFNZWT = M + 1
      GO TO 100
   40 RSTART = R
      IFNZWT = RSTART
      INZWT = 1
      IDNZWT = 1
C
C     CHECK WHETHER EACH DATA POINT WITH NONZERO WEIGHT
C     LIES IN THE CLOSED INTERVAL  XMIN  TO  XMAX
C
      IERROR = 1
      IW = 1 + (RSTART-2)*IW1
      DO 60 R = RSTART, M
         IW = IW + IW1
         IF ((X(R).LT.XMIN .OR. X(R).GT.XMAX) .AND. W(IW).NE.ZERO)
     *       GO TO 120
   60 CONTINUE
      IERROR = 0
      IF (RSTART.EQ.M) GO TO 100
C
C     CHECK WHETHER THE REMAINING DATA POINTS WITH NONZERO
C     WEIGHTS HAVE X-VALUES IN NONDECREASING ORDER, AND
C     DETERMINE THE VALUES OF  MNZWT  AND  MDNZWT
C
      IERROR = 0
      XPREV = X(RSTART)
      RSTART = RSTART + 1
      IW = 1 + (RSTART-2)*IW1
      DO 80 R = RSTART, M
         IW = IW + IW1
         IF (W(IW).EQ.ZERO) GO TO 80
         IF (X(R).LT.XPREV) IERROR = 2
         INZWT = INZWT + 1
         IF (X(R).GT.XPREV) IDNZWT = IDNZWT + 1
         XPREV = X(R)
   80 CONTINUE
  100 MNZWT = INZWT
      IF (IERROR.EQ.0) MDNZWT = IDNZWT
  120 IFAIL = IERROR
      RETURN
C
C     END E01DAX
C
      END
      SUBROUTINE E01DAY(NORDER,NKNOTS,M,X,W,IW1,LW,IFNZWT,MDNZWT,LAMBDA,
     *                  LLMBDA)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE B1K       PROVIDE TRIAL KNOT SET, GIVEN
C     ==============       ABSCISSAE AND WEIGHTS
C                          - BASE VERSION
C
C     CREATED 13 10 80.  UPDATED 16 03 83.  RELEASE 00/07
C
C     AUTHORS ... MAURICE G. COX, PAULINE E. M. CURTIS
C                 AND MICHAEL A. SINGER.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1980-1982
C
C     **********************************************************
C
C     B1K.  GIVEN A SET OF ABSCISSA (INDEPENDENT VARIABLE)
C     VALUES AND CORRESPONDING WEIGHTS, DETERMINES A SET OF
C     INTERIOR KNOTS SUCH THAT THERE IS AN APPROXIMATELY
C     EQUAL NUMBER OF ABSCISSAE WITH NONZERO WEIGHTS IN
C     EACH KNOT INTERVAL (EXCEPT IN THE FIRST AND LAST
C     INTERVALS WHERE THERE ARE APPROXIMATELY  NORDER/2
C     TIMES AS MANY VALUES).
C
C     INPUT PARAMETERS
C        NORDER   ORDER (DEGREE + 1) OF SPLINE  S
C        NKNOTS   NUMBER OF INTERIOR KNOTS
C        M        NUMBER OF INDEPENDENT VARIABLE VALUES
C        X        INDEPENDENT VARIABLE VALUES
C        W        WEIGHTS (INVERSELY PROPORTIONAL TO
C                    EXPECTED ERRORS IN F-VALUES)
C        IW1      INDEX INCREMENT OF  W
C        LW       DIMENSION OF  W
C        IFNZWT   INDEX OF FIRST DATA POINT WITH NONZERO
C                    WEIGHT
C        MDNZWT   NUMBER OF DATA POINTS WITH DISTINCT
C                    ABSCISSA VALUES AND NONZERO WEIGHT
C
C     OUTPUT (AND ASSOCIATED) PARAMETERS
C        LAMBDA   INTERIOR KNOTS
C        LLMBDA   DIMENSION OF  LAMBDA.
C                    .GE. MAX(NKNOTS, 1).
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      INTEGER           IFNZWT, IW1, LLMBDA, LW, M, MDNZWT, NKNOTS,
     *                  NORDER
C     .. Array Arguments ..
      DOUBLE PRECISION  LAMBDA(LLMBDA), W(LW), X(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  ALPHA, C1, DIST, HALF, ONE, PPJ, RI1, RM, RQ,
     *                  SI, XI, XINEXT, ZERO
      INTEGER           I, I1, I1L, IP1, ISTRT, IW, J, K, P
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MOD
C     .. Data statements ..
C
      DATA              ZERO, HALF, ONE/0.0D+0, 0.5D+0, 1.0D+0/
C     .. Executable Statements ..
C
      IF (NKNOTS.LE.0) GO TO 120
      RM = MDNZWT
      RQ = NKNOTS + NORDER
      P = NORDER/2
      IF (MOD(NORDER,2).NE.0) GO TO 20
C
C        NORDER  EVEN
C
      DIST = (RM-ONE)/(RQ-ONE)
      C1 = ONE - DIST
      GO TO 40
C
C        NORDER  ODD
C
   20 DIST = RM/RQ
      C1 = HALF
C
C     NOW FORM THE KNOTS
C
   40 I1L = 0
      I = IFNZWT
      XINEXT = X(I)
      IW = 1 + (IFNZWT-1)*IW1
      DO 100 J = 1, NKNOTS
         PPJ = P + J
         SI = C1 + PPJ*DIST
         I1 = INT(SI)
         RI1 = I1
         ALPHA = SI - RI1
         ISTRT = I1L + 1
         I1L = I1
         DO 80 K = ISTRT, I1
            XI = XINEXT
            IP1 = I + 1
C
C           DETERMINE  XINEXT,  THE NEXT X-VALUE WITH
C           NONZERO WEIGHT THAT IS DISTINCT FROM THE
C           PREVIOUS SUCH X-VALUE
C
            DO 60 I = IP1, M
               XINEXT = X(I)
               IW = IW + IW1
               IF (W(IW).NE.ZERO .AND. XINEXT.NE.XI) GO TO 80
   60       CONTINUE
   80    CONTINUE
         LAMBDA(J) = (ONE-ALPHA)*XI + ALPHA*XINEXT
  100 CONTINUE
  120 CONTINUE
      RETURN
C
C     END E01DAY
C
      END
      SUBROUTINE E01DAZ(NXORDR,NXKNTS,XMIN,XMAX,NYORDR,NYKNTS,YMIN,YMAX,
     *                  MX,X,MY,Y,F,IF1,IF2,LF,XLAM,LXLAM,YLAM,LYLAM,C,
     *                  IC1,IC2,LC,XUFCTR,LXU,YUFCTR,LYU,E,IE1,IE2,LE,
     *                  XKNOT,LXKNOT,YKNOT,LYKNOT,XROW,LXROW,YROW,LYROW,
     *                  WRK,LWRK,IFAIL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE B2IR      BIVARIATE POLYNOMIAL SPLINE
C     ===============      INTERPOLANT TO DATA ON
C                          RECTANGULAR MESH
C                          - BASE VERSION
C
C     CREATED 24 09 81.  UPDATED 15 11 82.  RELEASE 00/07
C
C     AUTHOR ... MAURICE G. COX.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1981-1982
C
C     **********************************************************
C
C     B2IR.  DETERMINES A POLYNOMIAL SPLINE
C     INTERPOLANT TO DATA SPECIFIED AT ALL MESHPOINTS OF A
C     RECTANGULAR MESH.
C
C     INPUT PARAMETERS
C        NXORDR   ORDER (DEGREE + 1) OF  SPLINE  S  IN  X
C        NXKNTS   NUMBER OF INTERIOR X-KNOTS
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF X-INTERVAL
C        NYORDR   ORDER OF  S  IN  Y
C        NYKNTS   NUMBER OF INTERIOR Y-KNOTS
C        YMIN,
C        YMAX     LOWER AND UPPER ENDPOINTS OF Y-INTERVAL
C        MX       NUMBER OF X-MESHLINES
C        X        X-MESHLINE VALUES
C        MY       NUMBER OF Y-MESHLINES
C        Y        Y-MESHLINE VALUES
C        F        DEPENDENT VARIABLE VALUES
C        IF1,
C        IF2      INDEX INCREMENTS OF  F
C        LF       DIMENSION OF  F
C
C     OUTPUT (AND ASSOCIATED DIMENSION) PARAMETERS
C        XLAM     INTERIOR X-KNOTLINES
C        LXLAM    DIMENSION OF  XLAM.  .GE. MAX(NXKNTS, 1).
C        YLAM     INTERIOR Y-KNOTLINES
C        LYLAM    DIMENSION OF  YLAM.  .GE. MAX(NYKNTS, 1).
C        C        B-SPLINE COEFFICIENTS OF  S
C        IC1,
C        IC2      INDEX INCREMENTS OF  C
C        LC       DIMENSION OF  C
C
C     WORKSPACE (AND ASSOCIATED DIMENSION) PARAMETERS
C        XUFCTR   BAND UPPER TRIANGULAR MATRIX FOR  X
C        LXU      DIMENSION OF  XUFCTR.
C                    .GE. NXORDR*(MX + NXKNTS + 1)/2
C        YUFCTR   BAND UPPER TRIANGULAR MATRIX FOR  Y
C        LYU      DIMENSION OF  YUFCTR.
C                    .GE. NYORDR*(MY + NYKNTS + 1)/2
C        E        INTERMEDIATE COEFFICIENTS FROM FIRST FIT
C        IE1,
C        IE2      INDEX INCREMENTS OF  E
C        LE       DIMENSION OF  E  .GE.  MY*MX.
C        XKNOT    KNOTS USED IN COMPUTING B-SPLINE BASIS
C                    FOR CURRENT X-VALUE
C        LXKNOT   DIMENSION OF  XKNOT.  .GE. 2*NXORDR.
C        YKNOT    KNOTS USED IN COMPUTING B-SPLINE BASIS
C                    FOR CURRENT Y-VALUE
C        LYKNOT   DIMENSION OF  YKNOT.  .GE. 2*NYORDR.
C        XROW     OBSERVATIONAL ROW CONTAINING B-SPLINE
C                    BASIS VALUES FOR CURRENT X-VALUE
C        LXROW    DIMENSION OF  XROW.  .GE. MX.
C        YROW     OBSERVATIONAL ROW CONTAINING B-SPLINE
C                    BASIS VALUES FOR CURRENT Y-VALUE
C        LYROW    DIMENSION OF  YROW.  .GE. MY.
C        WRK      WORKSPACE REQUIRED BY  ERB
C        LWRK     DIMENSION OF  WRK.  .GE. MAX(MX, MY).
C
C     FAILURE INDICATOR PARAMETER
C        IFAIL    FAILURE INDICATOR
C                    1 - NUMERICALLY SINGULAR SYSTEM
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN, YMAX, YMIN
      INTEGER           IC1, IC2, IE1, IE2, IF1, IF2, IFAIL, LC, LE, LF,
     *                  LWRK, LXKNOT, LXLAM, LXROW, LXU, LYKNOT, LYLAM,
     *                  LYROW, LYU, MX, MY, NXKNTS, NXORDR, NYKNTS,
     *                  NYORDR
C     .. Array Arguments ..
      DOUBLE PRECISION  C(LC), E(LE), F(LF), WRK(LWRK), X(MX),
     *                  XKNOT(LXKNOT), XLAM(LXLAM), XROW(LXROW),
     *                  XUFCTR(LXU), Y(MY), YKNOT(LYKNOT), YLAM(LYLAM),
     *                  YROW(LYROW), YUFCTR(LYU)
C     .. Local Scalars ..
      INTEGER           IERROR
C     .. External Subroutines ..
      EXTERNAL          E01DAW
C     .. Executable Statements ..
C
C     CONSTRUCT POLYNOMIAL SPLINE INTERPOLANT TO F-VALUES
C     ALONG EACH Y-MESHLINE
C
      CALL E01DAW(NXORDR,XMIN,XMAX,MX,X,MY,F,IF1,IF2,LF,NXKNTS,XLAM,
     *            LXLAM,E,IE1,IE2,LE,XUFCTR,LXU,XKNOT,LXKNOT,XROW,LXROW,
     *            WRK,LWRK,IERROR)
      IF (IERROR.NE.0) GO TO 20
C
C     CONSTRUCT POLYNOMIAL SPLINE INTERPOLANT TO THE
C     COEFFICIENTS SO OBTAINED ALONG EACH X-MESHLINE
C
      CALL E01DAW(NYORDR,YMIN,YMAX,MY,Y,MX,E,IE2,IE1,LE,NYKNTS,YLAM,
     *            LYLAM,C,IC2,IC1,LC,YUFCTR,LYU,YKNOT,LYKNOT,YROW,LYROW,
     *            WRK,LWRK,IERROR)
   20 IFAIL = IERROR
      RETURN
C
C     END E01DAZ
C
      END
      SUBROUTINE E02ACF(X,Y,N,AA,M1,REF)
C     MARK 1 RELEASE.  NAG COPYRIGHT 1971
C     MARK 4.5 REVISED
C     MARK 5C REVISED
C     MARK 9B REVISED. IER-361 (JAN 1982)
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 14C REVISED. IER-877 (NOV 1990).
C     CALCULATES A MINIMAX POLYNOMIAL FIT TO A SET OF DATA POINTS
C     AS A
C     SERIES OF CHEBYSHEV POLYNOMIALS.
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02ACF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  REF
      INTEGER           M1, N
C     .. Array Arguments ..
      DOUBLE PRECISION  AA(M1), X(N), Y(N)
C     .. Local Scalars ..
      DOUBLE PRECISION  ABSHI, AI, AI1, D, DENOM, H, HI, HIMAX, HMAX,
     *                  ONE, P1, P5, PREVH, RHI, RHI1, XI, XJ, XNEXTH,
     *                  ZERO
      INTEGER           I, I1, I2, IFAIL, IJ1, IMAX, IRI, IRJ, J, J1, K,
     *                  M, M2
C     .. Local Arrays ..
      DOUBLE PRECISION  A(100), RH(100), RX(100)
      INTEGER           IR(100)
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, INT
C     .. Data statements ..
      DATA              ZERO/0.0D0/, ONE/1.0D0/, P5/0.5D0/, P1/0.1D0/
C     .. Executable Statements ..
C     ENFORCED HARD FAIL FOR OUT-OF-BOUNDS PARAMETERS
      IF (M1.GE.N .OR. M1.GE.100) IFAIL = P01ABF(0,1,SRNAME,0,P01REC)
      DO 20 I = 2, N
         IF (X(I).LE.X(I-1)) IFAIL = P01ABF(0,2,SRNAME,0,P01REC)
   20 CONTINUE
      M2 = M1 + 1
      M = M1 - 1
      PREVH = -ONE
      IR(1) = 1
      IR(M2) = N
      D = DBLE(N-1)/DBLE(M1)
      H = D
      IF (M.EQ.0) GO TO 60
      DO 40 I = 2, M1
         IR(I) = INT(H+P5) + 1
         H = H + D
   40 CONTINUE
   60 H = -ONE
      DO 80 I = 1, M2
         IRI = IR(I)
         RX(I) = X(IRI)
         A(I) = Y(IRI)
         RH(I) = -H
         H = -H
   80 CONTINUE
      DO 120 J = 1, M1
         I1 = M2
         AI1 = A(I1)
         RHI1 = RH(I1)
         I = M2
  100    I = I - 1
         IJ1 = I - J + 1
         DENOM = RX(I1) - RX(IJ1)
         AI = A(I)
         RHI = RH(I)
         A(I1) = (AI1-AI)/DENOM
         RH(I1) = (RHI1-RHI)/DENOM
         I1 = I
         AI1 = AI
         RHI1 = RHI
         IF (I-J) 120, 120, 100
  120 CONTINUE
      H = -A(M2)/RH(M2)
      DO 140 I = 1, M2
         A(I) = A(I) + RH(I)*H
  140 CONTINUE
      IF (M.EQ.0) GO TO 200
      J = M1
  160 J = J - 1
      XJ = RX(J)
      I = J
      AI = A(I)
      J = J + 1
      DO 180 I1 = J, M1
         AI1 = A(I1)
         A(I) = AI - XJ*AI1
         AI = AI1
         I = I1
  180 CONTINUE
      J = J - 1
      IF (J-1) 200, 200, 160
  200 CONTINUE
      HMAX = ABS(H)
      IF (HMAX.GT.PREVH) GO TO 220
      A(M2) = -HMAX
      GO TO 480
  220 A(M2) = HMAX
      PREVH = HMAX
      IMAX = IR(1)
      HIMAX = H
      J = 1
      IRJ = IR(J)
      DO 300 I = 1, N
         IF (I.EQ.IRJ) GO TO 280
         XI = X(I)
         HI = ZERO
         K = M2
  240    K = K - 1
         HI = HI*XI + A(K)
         IF (K-1) 260, 260, 240
  260    HI = HI - Y(I)
         ABSHI = ABS(HI)
         IF (ABSHI.LE.HMAX) GO TO 300
         HMAX = ABSHI
         HIMAX = HI
         IMAX = I
         GO TO 300
  280    IF (J.GE.M2) GO TO 300
         J = J + 1
         IRJ = IR(J)
  300 CONTINUE
      IF (IMAX.EQ.IR(1)) GO TO 480
      DO 320 I = 1, M2
         IF (IMAX.LT.IR(I)) GO TO 340
  320 CONTINUE
      I = M2
  340 I2 = INT(DBLE(I)*P5)
      I2 = I - 2*I2
      XNEXTH = H
      IF (I2.EQ.0) XNEXTH = -H
      IF (HIMAX*XNEXTH.LT.0.0D0) GO TO 360
      IR(I) = IMAX
      GO TO 60
  360 IF (IMAX.GE.IR(1)) GO TO 420
      J1 = M2
      J = M2
  380 J = J - 1
      IR(J1) = IR(J)
      J1 = J
      IF (J-1) 400, 400, 380
  400 IR(1) = IMAX
      GO TO 60
  420 IF (IMAX.LE.IR(M2)) GO TO 460
      J = 1
      DO 440 J1 = 2, M2
         IR(J) = IR(J1)
         J = J1
  440 CONTINUE
      IR(M2) = IMAX
      GO TO 60
  460 IR(I-1) = IMAX
      GO TO 60
  480 CONTINUE
      DO 500 I = 1, M1
         AA(I) = A(I)
  500 CONTINUE
      REF = A(M2)
      RETURN
      END
      SUBROUTINE E02ADF(M,KPLUS1,NROWS,X,Y,W,WORK1,WORK2,A,S,IFAIL)
C
C     NAG LIBRARY SUBROUTINE  E02ADF
C
C     E02ADF  COMPUTES WEIGHTED LEAST-SQUARES POLYNOMIAL
C     APPROXIMATIONS TO AN ARBITRARY SET OF DATA POINTS.
C
C     FORSYTHE-CLENSHAW METHOD WITH MODIFICATIONS DUE TO
C     REINSCH AND GENTLEMAN.
C
C     USES NAG LIBRARY ROUTINE  P01AAF.
C     USES BASIC EXTERNAL FUNCTION  SQRT.
C
C     STARTED - 1973.
C     COMPLETED - 1976.
C     AUTHOR - MGC AND JGH.
C
C     WORK1  AND  WORK2  ARE WORKSPACE AREAS.
C     WORK1(1, R)  CONTAINS THE VALUE OF THE  R TH  WEIGHTED
C     RESIDUAL FOR THE CURRENT DEGREE  I.
C     WORK1(2, R)  CONTAINS THE VALUE OF  X(R)  TRANSFORMED
C     TO THE RANGE  -1  TO  +1.
C     WORK1(3, R)  CONTAINS THE WEIGHTED VALUE OF THE CURRENT
C     ORTHOGONAL POLYNOMIAL (OF DEGREE  I)  AT THE  R TH
C     DATA POINT.
C     WORK2(1, J)  CONTAINS THE COEFFICIENT OF THE CHEBYSHEV
C     POLYNOMIAL OF DEGREE  J - 1  IN THE CHEBYSHEV-SERIES
C     REPRESENTATION OF THE CURRENT ORTHOGONAL POLYNOMIAL
C     (OF DEGREE  I).
C     WORK2(2, J)  CONTAINS THE COEFFICIENT OF THE CHEBYSHEV
C     POLYNOMIAL OF DEGREE  J - 1  IN THE CHEBYSHEV-SERIES
C     REPRESENTATION OF THE PREVIOUS ORTHOGONAL POLYNOMIAL
C     (OF DEGREE  I - 1).
C
C     NAG COPYRIGHT 1975
C     MARK 5 RELEASE
C     MARK 6 REVISED  IER-84
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     CHECK THAT THE VALUES OF  M  AND  KPLUS1  ARE REASONABLE
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02ADF')
C     .. Scalar Arguments ..
      INTEGER           IFAIL, KPLUS1, M, NROWS
C     .. Array Arguments ..
      DOUBLE PRECISION  A(NROWS,KPLUS1), S(KPLUS1), W(M), WORK1(3,M),
     *                  WORK2(2,KPLUS1), X(M), Y(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  ALPIP1, BETAI, BJ, BJP1, BJP2, CI, D, DF, DI,
     *                  DIM1, DJ, EPSR, FACTOR, PIJ, SIGMAI, WRPR,
     *                  WRPRSQ, X1, XCAPR, XM
      INTEGER           I, IERROR, IPLUS1, IPLUS2, J, JPLUS1, JPLUS2,
     *                  JREV, K, MDIST, R
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. Intrinsic Functions ..
      INTRINSIC         SQRT
C     .. Executable Statements ..
      IERROR = 4
      IF (KPLUS1.LT.1 .OR. M.LT.KPLUS1) GO TO 380
      K = KPLUS1 - 1
C
C     TEST THE VALIDITY OF THE DATA.
C
C     CHECK THAT THE WEIGHTS ARE STRICTLY POSITIVE.
C
      IERROR = 1
      DO 20 R = 1, M
         IF (W(R).LE.0.0D0) GO TO 380
   20 CONTINUE
C
C     CHECK THAT THE VALUES OF  X(R)  ARE NON-DECREASING AND
C     DETERMINE
C     THE NUMBER  (MDIST)  OF DISTINCT VALUES OF  X(R).
C
      IERROR = 2
      MDIST = 1
      DO 40 R = 2, M
         IF (X(R).LT.X(R-1)) GO TO 380
         IF (X(R).EQ.X(R-1)) GO TO 40
         MDIST = MDIST + 1
   40 CONTINUE
C
C     IF THE  X(R)  ALL HAVE THE SAME VALUE, I.E.  MDIST = 1,
C     THE NORMALIZATION OF THE INDEPENDENT VARIABLE IS NOT
C     POSSIBLE.
C
      IERROR = 3
      IF (MDIST.EQ.1) GO TO 380
C
C     IF THE NUMBER OF DISTINCT VALUES OF  X(R)  FAILS TO EXCEED
C     THE MAXIMUM DEGREE  K  THERE IS NO UNIQUE POLYNOMIAL
C     APPROXIMATION OF THAT DEGREE.
C
      IERROR = 4
      IF (MDIST.LE.K) GO TO 380
C
C     CHECK THAT  NROWS  HAS BEEN SET SUFFICIENTLY LARGE.
C
      IERROR = 5
      IF (NROWS.LT.KPLUS1) GO TO 380
      IERROR = 0
C
      X1 = X(1)
      XM = X(M)
      D = XM - X1
C
C     THE INITIAL VALUES  WORK1(1, R)  (R = 1, 2, ..., M)  OF THE
C     WEIGHTED RESIDUALS AND THE VALUES  WORK1(2, R)  (R = 1, 2,
C     ..., M)
C     OF THE NORMALIZED INDEPENDENT VARIABLE ARE COMPUTED.  NOTE
C     THAT
C     WORK1(2, R)  IS COMPUTED FROM THE EXPRESSION BELOW RATHER
C     THAN THE
C     MORE NATURAL FORM
C
C     (2.0*X(R) - X1 - XM)/D,
C
C     SINCE THE FORMER GUARANTEES THE COMPUTED VALUE TO DIFFER FROM
C     THE TRUE VALUE BY AT MOST  4.0*MACHINE ACCURACY,  WHEREAS THE
C     LATTER HAS NO SUCH GUARANTEE.
C
      DO 60 R = 1, M
         WORK1(1,R) = W(R)*Y(R)
         WORK1(2,R) = ((X(R)-X1)-(XM-X(R)))/D
   60 CONTINUE
      I = 1
      BETAI = 0.0D0
      DO 360 IPLUS1 = 1, KPLUS1
C
C        SET STARTING VALUES FOR DEGREE  I.
C
         IPLUS2 = IPLUS1 + 1
         IF (IPLUS1.EQ.KPLUS1) GO TO 100
         DO 80 JPLUS1 = IPLUS2, KPLUS1
            A(IPLUS1,JPLUS1) = 0.0D0
   80    CONTINUE
         WORK2(1,IPLUS2) = 0.0D0
         WORK2(2,IPLUS2) = 0.0D0
  100    ALPIP1 = 0.0D0
         CI = 0.0D0
         DI = 0.0D0
         A(I,IPLUS1) = 0.0D0
         WORK2(1,IPLUS1) = 1.0D0
         IF (KPLUS1.GT.1) WORK2(2,1) = WORK2(1,2)
         DO 260 R = 1, M
            XCAPR = WORK1(2,R)
C
C           THE WEIGHTED VALUE  WORK1(3, R)  OF THE ORTHOGONAL
C           POLYNOMIAL OF
C           DEGREE  I  AT  X = X(R)  IS COMPUTED BY RECURRENCE FROM ITS
C           CHEBYSHEV-SERIES REPRESENTATION.
C
            IF (IPLUS1.GT.1) GO TO 120
            WRPR = W(R)*0.5D0*WORK2(1,1)
            WORK1(3,R) = WRPR
            GO TO 240
  120       J = IPLUS2
            IF (XCAPR.GT.0.5D0) GO TO 200
            IF (XCAPR.GE.-0.5D0) GO TO 160
C
C           GENTLEMAN*S MODIFIED RECURRENCE.
C
            FACTOR = 2.0D0*(1.0D0+XCAPR)
            DJ = 0.0D0
            BJ = 0.0D0
            DO 140 JREV = 1, I
               J = J - 1
               DJ = WORK2(1,J) - DJ + FACTOR*BJ
               BJ = DJ - BJ
  140       CONTINUE
            WRPR = W(R)*(0.5D0*WORK2(1,1)-DJ+0.5D0*FACTOR*BJ)
            WORK1(3,R) = WRPR
            GO TO 240
C
C           CLENSHAW*S ORIGINAL RECURRENCE.
C
  160       FACTOR = 2.0D0*XCAPR
            BJP1 = 0.0D0
            BJ = 0.0D0
            DO 180 JREV = 1, I
               J = J - 1
               BJP2 = BJP1
               BJP1 = BJ
               BJ = WORK2(1,J) - BJP2 + FACTOR*BJP1
  180       CONTINUE
            WRPR = W(R)*(0.5D0*WORK2(1,1)-BJP1+0.5D0*FACTOR*BJ)
            WORK1(3,R) = WRPR
            GO TO 240
C
C           REINSCH*S MODIFIED RECURRENCE.
C
  200       FACTOR = 2.0D0*(1.0D0-XCAPR)
            DJ = 0.0D0
            BJ = 0.0D0
            DO 220 JREV = 1, I
               J = J - 1
               DJ = WORK2(1,J) + DJ - FACTOR*BJ
               BJ = BJ + DJ
  220       CONTINUE
            WRPR = W(R)*(0.5D0*WORK2(1,1)+DJ-0.5D0*FACTOR*BJ)
            WORK1(3,R) = WRPR
C
C           THE COEFFICIENT  CI  OF THE  I TH  ORTHOGONAL POLYNOMIAL AND
C           THE
C           COEFFICIENTS  ALPIP1  AND  BETA I  IN THE
C           THREE-TERM RECURRENCE RELATION FOR THE ORTHOGONAL
C           POLYNOMIALS ARE COMPUTED.
C
  240       WRPRSQ = WRPR**2
            DI = DI + WRPRSQ
            CI = CI + WRPR*WORK1(1,R)
            ALPIP1 = ALPIP1 + WRPRSQ*XCAPR
  260    CONTINUE
         CI = CI/DI
         IF (IPLUS1.NE.1) BETAI = DI/DIM1
         ALPIP1 = 2.0D0*ALPIP1/DI
C
C        THE WEIGHTED RESIDUALS  WORK1(1, R)  (R = 1, 2, ..., M)  FOR
C        DEGREE  I  ARE COMPUTED, TOGETHER WITH THEIR SUM OF SQUARES,
C        SIGMAI.
C
         SIGMAI = 0.0D0
         DO 280 R = 1, M
            EPSR = WORK1(1,R) - CI*WORK1(3,R)
            WORK1(1,R) = EPSR
            SIGMAI = SIGMAI + EPSR**2
  280    CONTINUE
C
C        THE ROOT MEAN SQUARE RESIDUAL  S(I + 1)  FOR DEGREE  I  IS
C        THEORETICALLY UNDEFINED IF  M = I + 1  (THE CONDITION FOR THE
C        POLYNOMIAL TO PASS EXACTLY THROUGH THE DATA POINTS).  SHOULD
C        THIS
C        CASE ARISE THE R.M.S. RESIDUAL IS SET TO ZERO.
C
         IF (IPLUS1.GE.M) GO TO 300
         DF = M - IPLUS1
         S(IPLUS1) = SQRT(SIGMAI/DF)
         GO TO 320
  300    S(IPLUS1) = 0.0D0
C
C        THE CHEBYSHEV COEFFICIENTS  A(I + 1, 1), A(I + 1, 2), ...,
C        A(I + 1, I + 1)  TOGETHER WITH THE COEFFICIENTS
C        WORK2(1, 1), WORK2(1, 2), ..., WORK2(1, I + 1),   IN THE
C        CHEBYSHEV-SERIES REPRESENTATION OF THE  I TH  ORTHOGONAL
C        POLYNOMIAL ARE COMPUTED.
C
  320    DO 340 JPLUS1 = 1, IPLUS1
            JPLUS2 = JPLUS1 + 1
            PIJ = WORK2(1,JPLUS1)
            A(IPLUS1,JPLUS1) = A(I,JPLUS1) + CI*PIJ
            IF (JPLUS2.GT.KPLUS1) GO TO 380
            WORK2(1,JPLUS1) = WORK2(1,JPLUS2) + WORK2(2,JPLUS1) -
     *                        ALPIP1*PIJ - BETAI*WORK2(2,JPLUS2)
            WORK2(2,JPLUS2) = PIJ
  340    CONTINUE
         DIM1 = DI
         I = IPLUS1
  360 CONTINUE
  380 IF (IERROR) 400, 420, 400
  400 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
  420 IFAIL = 0
      RETURN
      END

      SUBROUTINE E02ADZ(MFIRST,MLAST,MTOT,KPLUS1,NROWS,KALL,NDV,X,Y,W,
     *                  XMIN,XMAX,INUP1,NU,WORK1,WORK2,A,S,SERR,EPS,
     *                  IFAIL)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978.
C     MARK 8 REVISED. IER-228 (APR 1980).
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     E02ADZ  COMPUTES WEIGHTED LEAST-SQUARES POLYNOMIAL
C     APPROXIMATIONS TO AN ARBITRARY SET OF DATA POINTS,
C     WITH, IF REQUIRED, SEVERAL SETS OF VALUES OF THE
C     DEPENDENT VARIABLE.
C
C     FORSYTHE-CLENSHAW METHOD WITH MODIFICATIONS DUE TO
C     REINSCH AND GENTLEMAN.
C
C     STARTED - 1973.
C     COMPLETED - 1978.
C     AUTHORS - MGC AND GTA.
C
C     WORK1  AND  WORK2  ARE WORKSPACE AREAS.
C     WORK1(1, R)  CONTAINS THE VALUE OF  X(R)  TRANSFORMED
C     TO THE RANGE  -1  TO  +1.
C     WORK1(2, R)  CONTAINS THE WEIGHTED VALUE OF THE CURRENT
C     ORTHOGONAL POLYNOMIAL (OF DEGREE  I)  AT THE  R TH
C     DATA POINT.
C     WORK2(1, J)  CONTAINS THE COEFFICIENT OF THE CHEBYSHEV
C     POLYNOMIAL OF DEGREE  J - 1  IN THE CHEBYSHEV-SERIES
C     REPRESENTATION OF THE CURRENT ORTHOGONAL POLYNOMIAL
C     (OF DEGREE  I).
C     WORK2(2, J)  CONTAINS THE COEFFICIENT OF THE CHEBYSHEV
C     POLYNOMIAL OF DEGREE  J - 1  IN THE CHEBYSHEV-SERIES
C     REPRESENTATION OF THE PREVIOUS ORTHOGONAL POLYNOMIAL
C     (OF DEGREE  I - 1).
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           IFAIL, INUP1, KALL, KPLUS1, MFIRST, MLAST, MTOT,
     *                  NDV, NROWS
C     .. Array Arguments ..
      DOUBLE PRECISION  A(NDV,NROWS,KPLUS1), EPS(NDV,MLAST), NU(INUP1),
     *                  S(NDV,KPLUS1), SERR(KPLUS1), W(MLAST),
     *                  WORK1(2,MTOT), WORK2(2,KPLUS1), X(MLAST),
     *                  Y(NDV,MLAST)
C     .. Local Scalars ..
      DOUBLE PRECISION  ALPIP1, BETAI, BJ, BJP1, BJP2, CIL, D, DF, DI,
     *                  DIM1, DJ, EPSLR, FACTOR, PIJ, SIGMAI, WR, WRPR,
     *                  WRPRSQ, X1, XCAPR, XM
      INTEGER           I, IERROR, II, IM1, INU, IPLUS1, IPLUS2, J,
     *                  JPLUS1, JPLUS2, JREV, K, L, M, MDIST, MR, R
      LOGICAL           WNZ
C     .. Local Arrays ..
      DOUBLE PRECISION  CI(10)
C     .. Intrinsic Functions ..
      INTRINSIC         SQRT
C     .. Executable Statements ..
      K = KPLUS1 - 1
      INU = INUP1 - 1
C
C     TEST THE VALIDITY OF THE DATA.
C
C     CHECK INPUT PARAMETERS.
C
      M = MLAST - MFIRST + 1
      I = KPLUS1 - INU
      IERROR = 5
      IF (MFIRST.LT.1 .OR. INUP1.LT.1 .OR. KPLUS1.LT.INUP1 .OR. M.LT.
     *    I .OR. NDV.LT.1 .OR. (KALL.NE.1 .AND. KALL.NE.0)) GO TO 600
C
C     CHECK THAT THE VALUES OF X(R) ARE NON-DECREASING AND
C     DETERMINE THE NUMBER (MDIST) OF DISTINCT VALUES OF X(R)
C     WITH NON-ZERO WEIGHT
C
      IERROR = 2
      MDIST = 1
      IF (W(MFIRST).EQ.0.0D+0) MDIST = 0
      L = MFIRST + 1
      IF (L.GT.MLAST) GO TO 40
      WNZ = W(MFIRST) .NE. 0.0D+0
      DO 20 R = L, MLAST
         IF (X(R).LT.X(R-1)) GO TO 600
         IF (X(R).GT.X(R-1)) WNZ = .FALSE.
         IF (W(R).EQ.0.0D+0 .OR. WNZ) GO TO 20
         MDIST = MDIST + 1
         WNZ = .TRUE.
   20 CONTINUE
C
C     CHECK THAT XMIN.LT.XMAX AND THAT XMIN AND XMAX SPAN THE DATA
C     X VALUES.
C
   40 IERROR = 1
      IF (XMIN.GT.X(MFIRST) .OR. XMAX.LT.X(MLAST) .OR. XMIN.GE.XMAX)
     *    GO TO 600
C
C     IF THE NUMBER OF DISTINCT VALUES OF  X(R)  WITH NON-ZERO
C     WEIGHT IS LESS THAN THE NUMBER OF INDEPENDENT COEFFICIENTS
C     IN THE FIT OF MAXIMUM DEGREE  K  THERE IS NO UNIQUE
C     POLYNOMIAL
C     APPROXIMATION OF THAT DEGREE.
C
      L = K - INU
      IERROR = 3
      IF (MDIST.LE.L) GO TO 600
C
C     CHECK THAT  NROWS  HAS BEEN SET SUFFICIENTLY LARGE.
C
      IERROR = 5
      IF (KALL.EQ.1 .AND. NROWS.LT.KPLUS1) GO TO 600
      IF (INUP1.EQ.1) GO TO 80
C
C     NORMALIZE THE FORCING FACTOR SO THAT ITS LEADING COEFFICIENT
C     IS UNITY, CHECKING THAT THIS COEFFICIENT WAS NOT ZERO.
C
      IERROR = 4
      DI = NU(INUP1)
      IF (DI.EQ.0.0D0) GO TO 600
      DO 60 I = 1, INUP1
         WORK2(1,I) = NU(I)/DI
         WORK2(2,I) = 0.0D0
   60 CONTINUE
C
   80 IERROR = 0
      X1 = XMIN
      XM = XMAX
      D = XM - X1
C
C     THE INITIAL VALUES OF EPS(L,R) (L = 1,2,....NDV AND R =
C     MFIRST, MFIRST+1,....MLAST) OF THE WEIGHTED RESIDUALS AND
C     THE VALUES WORK1(1,R)(R=1,2...M) OF THE NORMALIZED
C     INDEPENDENT VARIABLE ARE COMPUTED. N.B. WORK1(1,R) IS
C     COMPUTED FROM THE EXPRESSION BELOW RATHER THAN THE MORE
C     NATURAL FORM   (2.0*X(R) - X1 - XM)/D
C     SINCE THE FORMER GUARANTEES THE COMPUTED VALUE TO DIFFER FROM
C     THE TRUE VALUE BY AT MOST  4.0*MACHINE ACCURACY,  WHEREAS THE
C     LATTER HAS NO SUCH GUARANTEE.
C
C     MDIST IS NOW USED TO RECORD THE TOTAL NUMBER OF DATA POINTS
C     WITH NON-ZERO WEIGHT.
C
      MDIST = 0
      DO 120 R = MFIRST, MLAST
         WR = W(R)
         IF (WR.NE.0.0D0) MDIST = MDIST + 1
         MR = R - MFIRST + 1
         DO 100 L = 1, NDV
            EPS(L,R) = WR*Y(L,R)
  100    CONTINUE
         WORK1(1,MR) = ((X(R)-X1)-(XM-X(R)))/D
  120 CONTINUE
      IM1 = INU*KALL + 1
      BETAI = 0.0D0
      DO 160 JPLUS1 = 1, KPLUS1
         SERR(JPLUS1) = 0.0D0
         DO 140 L = 1, NDV
            A(L,IM1,JPLUS1) = 0.0D0
  140    CONTINUE
  160 CONTINUE
      DO 560 IPLUS1 = INUP1, KPLUS1
C
C        SET STARTING VALUES FOR DEGREE  I.
C
         II = (IPLUS1-1)*KALL + 1
         IPLUS2 = IPLUS1 + 1
         IF (IPLUS1.EQ.KPLUS1) GO TO 240
         IF (KALL.EQ.0) GO TO 220
         DO 200 JPLUS1 = IPLUS2, KPLUS1
            DO 180 L = 1, NDV
               A(L,II,JPLUS1) = 0.0D0
  180       CONTINUE
  200    CONTINUE
  220    WORK2(1,IPLUS2) = 0.0D0
         WORK2(2,IPLUS2) = 0.0D0
  240    ALPIP1 = 0.0D0
         DI = 0.0D0
         DO 260 L = 1, NDV
            CI(L) = 0.0D0
  260    CONTINUE
         WORK2(1,IPLUS1) = 1.0D0
         IF (KPLUS1.GT.1) WORK2(2,1) = WORK2(1,2)
         DO 440 R = MFIRST, MLAST
            IF (W(R).EQ.0.0D0) GO TO 440
            MR = R - MFIRST + 1
            XCAPR = WORK1(1,MR)
C
C           THE WEIGHTED VALUE WORK1(2, R)  OF THE ORTHOGONAL POLYNOMIAL
C           OF DEGREE I AT X = X(R) IS COMPUTED BY RECURRENCE FROM ITS
C           CHEBYSHEV-SERIES REPRESENTATION.
C
            IF (IPLUS1.GT.1) GO TO 280
            WRPR = W(R)*0.5D0*WORK2(1,1)
            WORK1(2,MR) = WRPR
            GO TO 400
  280       J = IPLUS2
            IF (XCAPR.GT.0.5D0) GO TO 360
            IF (XCAPR.GE.-0.5D0) GO TO 320
C
C           GENTLEMAN*S MODIFIED RECURRENCE.
C
            FACTOR = 2.0D0*(1.0D0+XCAPR)
            DJ = 0.0D0
            BJ = 0.0D0
            DO 300 JREV = 2, IPLUS1
               J = J - 1
               DJ = WORK2(1,J) - DJ + FACTOR*BJ
               BJ = DJ - BJ
  300       CONTINUE
            WRPR = W(R)*(0.5D0*WORK2(1,1)-DJ+0.5D0*FACTOR*BJ)
            WORK1(2,MR) = WRPR
            GO TO 400
C
C           CLENSHAW*S ORIGINAL RECURRENCE.
C
  320       FACTOR = 2.0D0*XCAPR
            BJP1 = 0.0D0
            BJ = 0.0D0
            DO 340 JREV = 2, IPLUS1
               J = J - 1
               BJP2 = BJP1
               BJP1 = BJ
               BJ = WORK2(1,J) - BJP2 + FACTOR*BJP1
  340       CONTINUE
            WRPR = W(R)*(0.5D0*WORK2(1,1)-BJP1+0.5D0*FACTOR*BJ)
            WORK1(2,MR) = WRPR
            GO TO 400
C
C           REINSCH*S MODIFIED RECURRENCE.
C
  360       FACTOR = 2.0D0*(1.0D0-XCAPR)
            DJ = 0.0D0
            BJ = 0.0D0
            DO 380 JREV = 2, IPLUS1
               J = J - 1
               DJ = WORK2(1,J) + DJ - FACTOR*BJ
               BJ = BJ + DJ
  380       CONTINUE
            WRPR = W(R)*(0.5D0*WORK2(1,1)+DJ-0.5D0*FACTOR*BJ)
            WORK1(2,MR) = WRPR
C
C           THE COEFFICIENTS CI(L) OF THE I TH ORTHOGONAL POLYNOMIAL
C           L=1,2....NDV AND THE COEFFICIENTS ALPIP1 AND BETAI IN THE
C           THREE-TERM RECURRENCE RELATION FOR THE ORTHOGONAL
C           POLYNOMIALS ARE COMPUTED.
C
  400       WRPRSQ = WRPR**2
            DI = DI + WRPRSQ
            DO 420 L = 1, NDV
               CI(L) = CI(L) + WRPR*EPS(L,R)
  420       CONTINUE
            ALPIP1 = ALPIP1 + WRPRSQ*XCAPR
  440    CONTINUE
         DO 460 L = 1, NDV
            CI(L) = CI(L)/DI
  460    CONTINUE
         IF (IPLUS1.NE.INUP1) BETAI = DI/DIM1
         ALPIP1 = 2.0D0*ALPIP1/DI
C
C        THE WEIGHTED RESIDUALS EPS(L,R)(L=1,2....NDV AND R=MFIRST,
C        MFIRST+1....MLAST) FOR DEGREE I ARE COMPUTED, TOGETHER
C        WITH THEIR SUM OF SQUARES, SIGMAI
C
         DF = MDIST - (IPLUS1-INU)
         DO 500 L = 1, NDV
            CIL = CI(L)
            SIGMAI = 0.0D0
            DO 480 R = MFIRST, MLAST
               IF (W(R).EQ.0.0D0) GO TO 480
               MR = R - MFIRST + 1
               EPSLR = EPS(L,R) - CIL*WORK1(2,MR)
               EPS(L,R) = EPSLR
               SIGMAI = SIGMAI + EPSLR**2
  480       CONTINUE
C
C           THE ROOT MEAN SQUARE RESIDUAL  S(L, I + 1)  FOR DEGREE  I
C           IS THEORETICALLY UNDEFINED IF  M = I + 1 - INU  (THE
C           CONDITION FOR THE POLYNOMIAL TO PASS EXACTLY THROUGH THE
C           DATA POINTS). SHOULD THIS CASE ARISE THE R.M.S. RESIDUAL
C           IS SET TO ZERO.
C
            IF (DF.LE.0.0D0) S(L,IPLUS1) = 0.0D0
            IF (DF.GT.0.0D0) S(L,IPLUS1) = SQRT(SIGMAI/DF)
  500    CONTINUE
C
C        THE CHEBYSHEV COEFFICIENTS A(L, I+1, 1), A(L, I+1, 2)....
C        A(L, I+1, I+1) IN THE POLYNOMIAL APPROXIMATION OF DEGREE I
C        TO EACH SET OF VALUES OF THE INDEPENDENT VARIABLE
C        (L=1,2,...,NDV) TOGETHER WITH THE COEFFICIENTS
C        WORK2(1, 1), WORK2(1, 2), ..., WORK2(1, I + 1),   IN THE
C        CHEBYSHEV-SERIES REPRESENTATION OF THE  (I + 1) TH
C        ORTHOGONAL POLYNOMIAL ARE COMPUTED.
C
         DO 540 JPLUS1 = 1, IPLUS1
            JPLUS2 = JPLUS1 + 1
            PIJ = WORK2(1,JPLUS1)
            SERR(JPLUS1) = SERR(JPLUS1) + PIJ**2/DI
            DO 520 L = 1, NDV
               A(L,II,JPLUS1) = A(L,IM1,JPLUS1) + CI(L)*PIJ
  520       CONTINUE
            IF (JPLUS1.EQ.KPLUS1) GO TO 560
            WORK2(1,JPLUS1) = WORK2(1,JPLUS2) + WORK2(2,JPLUS1) -
     *                        ALPIP1*PIJ - BETAI*WORK2(2,JPLUS2)
            WORK2(2,JPLUS2) = PIJ
  540    CONTINUE
         DIM1 = DI
         IM1 = II
  560 CONTINUE
      DO 580 IPLUS1 = 1, KPLUS1
         SERR(IPLUS1) = 1.0D0/SQRT(SERR(IPLUS1))
  580 CONTINUE
  600 IFAIL = IERROR
      RETURN
      END

      SUBROUTINE E02AEF(NPLUS1,A,XCAP,P,IFAIL)
C     NAG LIBRARY SUBROUTINE  E02AEF
C
C     E02AEF  EVALUATES A POLYNOMIAL FROM ITS CHEBYSHEV-
C     SERIES REPRESENTATION.
C
C     CLENSHAW METHOD WITH MODIFICATIONS DUE TO REINSCH
C     AND GENTLEMAN.
C
C     USES NAG LIBRARY ROUTINES  P01ABF  AND  X02AJF.
C     USES INTRINSIC FUNCTION  ABS.
C
C     STARTED - 1973.
C     COMPLETED - 1976.
C     AUTHOR - MGC AND JGH.
C
C     NAG COPYRIGHT 1975
C     MARK 5 RELEASE
C     MARK 7 REVISED IER-140 (DEC 1978)
C     MARK 9 REVISED. IER-352 (SEP 1981)
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988).
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02AEF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  P, XCAP
      INTEGER           IFAIL, NPLUS1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(NPLUS1)
C     .. Local Scalars ..
      DOUBLE PRECISION  BK, BKP1, BKP2, DK, ETA, FACTOR
      INTEGER           IERROR, K, KREV, N, NPLUS2
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      DOUBLE PRECISION  X02AJF
      INTEGER           P01ABF
      EXTERNAL          X02AJF, P01ABF
C     .. Intrinsic Functions ..
      INTRINSIC         ABS
C     .. Executable Statements ..
      IERROR = 0
      ETA = X02AJF()
C     INSERT CALL TO X02AJF
C
C     ETA  IS THE SMALLEST POSITIVE NUMBER SUCH THAT
C     THE COMPUTED VALUE OF  1.0 + ETA  EXCEEDS UNITY.
C
      IF (NPLUS1.GE.1) GO TO 20
      IERROR = 2
      GO TO 180
   20 IF (ABS(XCAP).LE.1.0D0+4.0D0*ETA) GO TO 40
      IERROR = 1
      P = 0.0D0
      GO TO 180
   40 IF (NPLUS1.GT.1) GO TO 60
      P = 0.5D0*A(1)
      GO TO 180
   60 N = NPLUS1 - 1
      NPLUS2 = N + 2
      K = NPLUS2
      IF (XCAP.GT.0.5D0) GO TO 140
      IF (XCAP.GE.-0.5D0) GO TO 100
C
C     GENTLEMAN*S MODIFIED RECURRENCE.
C
      FACTOR = 2.0D0*(1.0D0+XCAP)
      DK = 0.0D0
      BK = 0.0D0
      DO 80 KREV = 1, N
         K = K - 1
         DK = A(K) - DK + FACTOR*BK
         BK = DK - BK
   80 CONTINUE
      P = 0.5D0*A(1) - DK + 0.5D0*FACTOR*BK
      GO TO 180
C
C     CLENSHAW*S ORIGINAL RECURRENCE.
C
  100 FACTOR = 2.0D0*XCAP
      BKP1 = 0.0D0
      BK = 0.0D0
      DO 120 KREV = 1, N
         K = K - 1
         BKP2 = BKP1
         BKP1 = BK
         BK = A(K) - BKP2 + FACTOR*BKP1
  120 CONTINUE
      P = 0.5D0*A(1) - BKP1 + 0.5D0*FACTOR*BK
      GO TO 180
C
C     REINSCH*S MODIFIED RECURRENCE.
C
  140 FACTOR = 2.0D0*(1.0D0-XCAP)
      DK = 0.0D0
      BK = 0.0D0
      DO 160 KREV = 1, N
         K = K - 1
         DK = A(K) + DK - FACTOR*BK
         BK = BK + DK
  160 CONTINUE
      P = 0.5D0*A(1) + DK - 0.5D0*FACTOR*BK
  180 IF (IERROR) 200, 220, 200
  200 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
  220 IFAIL = 0
      RETURN
      END

      SUBROUTINE E02AFF(NPLUS1,F,A,IFAIL)
C     NAG LIBRARY SUBROUTINE  E02AFF
C
C     E02AFF  COMPUTES THE COEFFICIENTS OF A POLYNOMIAL,
C     IN ITS CHEBYSHEV-SERIES FORM, WHICH INTERPOLATES
C     (PASSES EXACTLY THROUGH) DATA AT A SPECIAL SET OF
C     POINTS.  LEAST-SQUARES POLYNOMIAL APPROXIMATIONS
C     CAN ALSO BE OBTAINED.
C
C     CLENSHAW METHOD WITH MODIFICATIONS DUE TO REINSCH
C     AND GENTLEMAN.
C
C     USES NAG LIBRARY ROUTINES  P01AAF  AND  X01AAF.
C     USES BASIC EXTERNAL FUNCTION  SIN.
C
C     STARTED - 1973.
C     COMPLETED - 1976.
C     AUTHOR - MGC AND JGH.
C
C     NAG COPYRIGHT 1975
C     MARK 5 RELEASE
C     MARK 5B REVISED  IER-73
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02AFF')
C     .. Scalar Arguments ..
      INTEGER           IFAIL, NPLUS1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(NPLUS1), F(NPLUS1)
C     .. Local Scalars ..
      DOUBLE PRECISION  BK, BKP1, BKP2, DK, F0, FACTOR, FLI, FLN,
     *                  HALFFN, PI, PIBY2N
      INTEGER           I, IERROR, IPLUS1, J, K, KREV, N, N2, NLESS1
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      DOUBLE PRECISION  X01AAF
      INTEGER           P01ABF
      EXTERNAL          X01AAF, P01ABF
C     .. Intrinsic Functions ..
      INTRINSIC         SIN
C     .. Executable Statements ..
      IERROR = 0
      IF (NPLUS1.GT.2) GO TO 40
      IF (NPLUS1.EQ.2) GO TO 20
      IERROR = 1
      GO TO 180
   20 A(1) = F(1) + F(2)
      A(2) = 0.5D0*(F(1)-F(2))
      GO TO 180
C
C     SET THE VALUE OF  PI. INSERT CALL TO X01AAF
C
   40 PI = X01AAF(PI)
      N = NPLUS1 - 1
      FLN = N
      N2 = 2*N
      NLESS1 = N - 1
      PIBY2N = 0.5D0*PI/FLN
      F0 = F(1)
      HALFFN = 0.5D0*F(NPLUS1)
      DO 160 IPLUS1 = 1, NPLUS1
         I = IPLUS1 - 1
         K = NPLUS1
         J = 3*I
         IF (J.GT.N2) GO TO 120
         IF (J.GE.N) GO TO 80
C
C        REINSCH*S MODIFIED RECURRENCE.
C
         FLI = I
         FACTOR = 4.0D0*(SIN(PIBY2N*FLI))**2
         DK = HALFFN
         BK = HALFFN
         DO 60 KREV = 1, NLESS1
            K = K - 1
            DK = F(K) + DK - FACTOR*BK
            BK = BK + DK
   60    CONTINUE
         A(IPLUS1) = (F0+2.0D0*DK-FACTOR*BK)/FLN
         GO TO 160
C
C        CLENSHAW*S ORIGINAL RECURRENCE.
C
   80    FLI = N - 2*I
         FACTOR = 2.0D0*SIN(PIBY2N*FLI)
         BKP1 = 0.0D0
         BK = HALFFN
         DO 100 KREV = 1, NLESS1
            K = K - 1
            BKP2 = BKP1
            BKP1 = BK
            BK = F(K) - BKP2 + FACTOR*BKP1
  100    CONTINUE
         A(IPLUS1) = (F0-2.0D0*BKP1+FACTOR*BK)/FLN
         GO TO 160
C
C        GENTLEMAN*S MODIFIED RECURRENCE.
C
  120    FLI = N - I
         FACTOR = 4.0D0*(SIN(PIBY2N*FLI))**2
         DK = HALFFN
         BK = HALFFN
         DO 140 KREV = 1, NLESS1
            K = K - 1
            DK = F(K) - DK + FACTOR*BK
            BK = DK - BK
  140    CONTINUE
         A(IPLUS1) = (F0-2.0D0*DK+FACTOR*BK)/FLN
  160 CONTINUE
      A(NPLUS1) = 0.5D0*A(NPLUS1)
  180 IF (IERROR) 200, 220, 200
  200 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
  220 IFAIL = 0
      RETURN
      END

      SUBROUTINE E02AGF(M,KPLUS1,NROWS,XMIN,XMAX,X,Y,W,MF,XF,YF,LYF,IP,
     *                  A,S,NP1,WRK,LWRK,IWRK,LIWRK,IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 9 REVISED. IER-314 (SEP 1981).
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 14C REVISED. IER-878 (NOV 1990).
C
C     **************************************************************
C
C     NPL ALGORITHMS LIBRARY ROUTINE CONFIT
C
C     CREATED  20/8/1979      UPDATED  16/5/80     RELEASE NO. 00/05
C
C     AUTHOR... GERALD T ANTHONY.
C     NATIONAL PHYSICAL LABORATORY,
C     TEDDINGTON, MIDDLESEX TW11 0LW,
C     ENGLAND.
C
C     **************************************************************
C
C     E02AGF CALLS E01AEW TO DETERMINE A POLYNOMIAL MU(X) WHICH
C     INTERPOLATES THE GIVEN CONSTRAINTS AND A POLYNOMIAL NU(X)
C     WHICH HAS VALUE ZERO WHERE A CONSTRAINED VALUE IS SPECIFIED.
C     IT THEN CALLS E02ADZ TO FIT Y-MU(X) AS A POLYNOMIAL IN X
C     WITH FACTOR NU(X). FINALLY THE COEFFICIENTS OF MU ARE ADDED
C     TO THESE FITS TO GIVE THE COEFFICIENTS OF THE CONSTRAINED
C     FITS TO Y. ALL POLYNOMIALS ARE EXPRESSED IN CHEBYSHEV
C     SERIES FORM
C
C     INPUT PARAMETERS
C        M        THE NUMBER OF DATA POINTS TO BE FITTED
C        KPLUS1   FITS WITH UP TO KPLUS1 COEFFICIENTS ARE REQUIRED
C        NROWS    FIRST DIMENSION OF ARRAY A WHERE COEFFICIENTS ARE
C                 TO BE STORED
C        XMIN,    END POINTS OF THE RANGE OF THE
C        XMAX     INDEPENDENT VARIABLE
C        X, Y, W  ARRAYS OF DATA VALUES OF THE INDEPENDENT VARIABLE,
C                 DEPENDENT VARIABLE AND WEIGHT, RESPECTIVELY
C        MF       NUMBER OF X VALUES AT WHICH A CONSTRAINT
C                 IS SPECIFIED
C        XF       ARRAY OF VALUES OF THE INDEPENDENT
C                 VARIABLE AT WHICH CONSTRAINTS ARE
C                 SPECIFIED
C        YF       ARRAY OF SPECIFIED VALUES AND DERIVATIVES OF THE
C                 DEPENDENT VARIABLE IN THE ORDER
C                    Y1, Y1 DERIV, Y1 2ND DERIV,...., Y2,....
C        LYF      DIMENSION OF ARRAY YF
C        IP       INTEGER ARRAY OF DEGREES OF DERIVATIVES
C                 SPECIFIED AT EACH POINT XF
C
C     OUTPUT PARAMETERS
C        A        ON EXIT, 2 PARAMETER ARRAY CONTAINING THE
C                 COEFFICIENTS OF THE CHEBYSHEV SERIES
C                 REPRESENTATION OF THE FITS, A(I+1, J+1)
C                 CONTAINS THE COEFFICIENT OF TJ IN THE FIT
C                 OF DEGREE I, I = N,N+1,...,K,  J =
C                 0,1,...,I  WHERE N = NP1 - 1
C        S        ON EXIT, ARRAY CONTAINING THE R.M.S. RESIDUAL FOR
C                 EACH DEGREE OF FIT FROM N TO K
C        NP1      ON EXIT, CONTAINS N + 1, WHERE N IS THE
C                 TOTAL NUMBER OF INTERPOLATION CONDITIONS
C
C        IFAIL    FAILURE INDICATOR
C                  0 - SUCCESSFUL TERMINATION
C                  1 - AT LEAST ONE OF THE FOLLOWING CONDITIONS
C                      HAS BEEN VIOLATED
C                      LYF    AT LEAST N
C                      LWRK   AT LEAST 2*N + 2 + THE LARGER OF
C                             4*M + 3*KPLUS1 AND 8*NP1 +
C                             5*IMAX + MF - 3 WHERE IMAX =
C                             1 + MAX(IP(I))
C                      LIWRK  AT LEAST 2*MF + 2
C                      KPLUS1 AT LEAST NP1
C                      M      AT LEAST 1
C                      NROWS  AT LEAST KPLUS1
C                      MF     AT LEAST 1
C                  2 - FOR SOME I, IP(I) IS LESS THAN 0
C                  3 - XMIN IS NOT STRICTLY LESS THAN XMAX
C                      OR FOR SOME I, XF(I) IS NOT IN RANGE
C                      XMIN TO XMAX OR THE XF(I) ARE NOT
C                      DISTINCT
C                  4 - FOR SOME I, X(I) IS NOT IN RANGE XMIN TO XMAX
C                  5 - THE X(I) ARE NOT NON-DECREASING
C                  6 - THE NUMBER OF DISTINCT VALUES OF X(I) WITH
C                      NON-ZERO WEIGHT IS LESS THAN KPLUS1 - NP1
C                  7 - E01AEW HAS FAILED TO CONVERGE, IE
C                      THE CONSTRAINT CANNOT BE SATISFIED
C                      WITH SUFFICIENT ACCURACY
C
C     WORKSPACE PARAMETERS
C        WRK      REAL WORKSPACE ARRAY
C        LWRK     DIMENSION OF WRK.   LWRK MUST BE AT LEAST
C                 2*N + 2 + THE LARGER OF
C                 4*M + 3*KPLUS1 AND 8*NP1 + 5*IMAX + MF - 3
C                 WHERE IMAX = 1 + MAX(IP(I))
C        IWRK     INTEGER WORKSPACE ARRAY
C        LIWRK    DIMENSION OF IWRK.   LIWRK MUST BE AT LEAST
C                 2*MF + 2
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02AGF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           IFAIL, KPLUS1, LIWRK, LWRK, LYF, M, MF, NP1,
     *                  NROWS
C     .. Array Arguments ..
      DOUBLE PRECISION  A(NROWS,KPLUS1), S(KPLUS1), W(M), WRK(LWRK),
     *                  X(M), XF(MF), Y(M), YF(LYF)
      INTEGER           IP(MF), IWRK(LIWRK)
C     .. Local Scalars ..
      DOUBLE PRECISION  AMUJ, ONE, XI, XMU, ZERO
      INTEGER           I, IERROR, IM1, IMAX, IPI, IYMUX, J, LW, MDIST,
     *                  N, NANU, NEPS, NSER, NWRK, NWRK1, NWRK2
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          E01AEW, E02ADZ, E02AKF
C     .. Data statements ..
      DATA              ONE, ZERO/1.0D+0, 0.0D+0/
C     .. Executable Statements ..
      IERROR = 1
      IF (MF.LT.1) GO TO 280
      IERROR = 2
      IMAX = 0
      NP1 = 1
      DO 20 I = 1, MF
         IPI = IP(I) + 1
         IF (IPI.LT.1) GO TO 280
         IF (IPI.GT.IMAX) IMAX = IPI
         NP1 = NP1 + IPI
   20 CONTINUE
      N = NP1 - 1
      IERROR = 1
      IF (LYF.LT.N .OR. LIWRK.LT.2*MF+2) GO TO 280
      I = 4*M + 3*KPLUS1
      LW = 8*NP1 + 5*IMAX + MF - 3
      IF (LW.LT.I) LW = I
      LW = LW + 2*NP1
      IF (LW.GT.LWRK .OR. NP1.GT.KPLUS1 .OR. M.LT.1) GO TO 280
      NANU = NP1 + 1
      NWRK = NANU + NP1
      IERROR = 3
      IF (XMAX.LE.XMIN) GO TO 280
      IF (XF(1).GT.XMAX .OR. XF(1).LT.XMIN) GO TO 280
      IF (MF.EQ.1) GO TO 80
      DO 60 I = 2, MF
         XI = XF(I)
         IF (XI.GT.XMAX .OR. XI.LT.XMIN) GO TO 280
         IM1 = I - 1
         DO 40 J = 1, IM1
            IF (XI.EQ.XF(J)) GO TO 280
   40    CONTINUE
   60 CONTINUE
   80 IERROR = 6
      XMU = XMIN
      IF (X(1).EQ.XMIN) XMU = XMAX
      MDIST = 0
      DO 140 I = 1, M
         XI = X(I)
         IF (XI.EQ.XMU .OR. W(I).EQ.ZERO) GO TO 140
         DO 100 J = 1, MF
            IF (XI.EQ.XF(J)) GO TO 120
  100    CONTINUE
         MDIST = MDIST + 1
  120    XMU = XI
  140 CONTINUE
      IF (MDIST.LT.KPLUS1-N) GO TO 280
      IWRK(1) = 1
      IERROR = 1
      CALL E01AEW(MF,XMIN,XMAX,XF,YF,IP,N,NP1,5,20,WRK,WRK(NANU),
     *            WRK(NWRK),LWRK-NWRK+1,IWRK,LIWRK,IERROR)
      IF (IERROR.EQ.0) GO TO 160
      IERROR = 7
      GO TO 280
  160 DO 200 I = 1, M
         IERROR = 1
         CALL E02AKF(N,XMIN,XMAX,WRK,1,NP1,X(I),XMU,IERROR)
         IF (IERROR.EQ.0) GO TO 180
         IERROR = 4
         GO TO 280
  180    IYMUX = NWRK + I - 1
C
C        STORE Y - MU(X) AT ITH DATA POINT
C
         WRK(IYMUX) = Y(I) - XMU
  200 CONTINUE
      NWRK1 = NWRK + M
      NWRK2 = NWRK1 + 2*M
      NSER = NWRK2 + 2*KPLUS1
      NEPS = NSER + KPLUS1
      IERROR = 1
      CALL E02ADZ(1,M,M,KPLUS1,NROWS,1,1,X,WRK(NWRK),W,XMIN,XMAX,NP1,
     *            WRK(NANU),WRK(NWRK1),WRK(NWRK2),A,S,WRK(NSER),
     *            WRK(NEPS),IERROR)
      IF (IERROR.EQ.0) GO TO 220
      IERROR = IERROR + 3
      IF (IERROR.EQ.8) IERROR = 1
      GO TO 280
  220 DO 260 J = 1, N
         AMUJ = WRK(J)
         DO 240 I = NP1, KPLUS1
            A(I,J) = A(I,J) + AMUJ
  240    CONTINUE
  260 CONTINUE
  280 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
C     END E02AGF
      END
      SUBROUTINE E02AHF(NP1,XMIN,XMAX,A,IA1,LA,PATM1,ADIF,IADIF1,LADIF,
     *                  IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     NPL DATA FITTING LIBRARY ROUTINE CHBDIF
C
C     CREATED 1/5/79    UPDATED 23/1/80     RELEASE NO. 00/03
C
C     AUTHORS.. GERALD T ANTHONY, MAURICE G COX, J GEOFFREY HAYES.
C     NATIONAL PHYSICAL LABORATORY
C     TEDDINGTON, MIDDLESEX, ENGLAND.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     INPUT PARAMETERS
C        NP1    = N+1 WHERE N IS DEGREE OF GIVEN POLYNOMIAL
C        XMIN   LOWER LIMIT OF RANGE OF X
C        XMAX   UPPER LIMIT OF RANGE OF X
C        A      COEFFICIENTS A0, A1,...AN OF THE GIVEN POLYNOMIAL
C        IA1       ARE STORED IN ARRAY A IN POSITIONS 1, 1+IA1,...
C                  1+N*IA1, RESPECTIVELY
C        LA     THE DECLARED DIMENSION OF ARRAY A
C
C     OUTPUT PARAMETERS
C        PATM1  THE VALUE OF THE GIVEN POLYNOMIAL AT XMIN
C        ADIF   THE COEFFICIENTS OF THE DERIVATIVE POLYNOMIAL
C        IADIF1    ARE RETURNED IN ARRAY ADIF IN POSITIONS
C                  1, 1+IADIF1,...1+(N-1)*IADIF1
C        LADIF  THE DECLARED DIMENSION OF ARRAY ADIF
C        IFAIL  ERROR INDICATOR
C
C     DIFFERENTIATE THE SERIES WITH COEFFICIENTS A OF DEGREE N
C     (I.E. NP1 COEFFICIENTS) TO OBTAIN THE SERIES WITH COEFFICIENTS
C     ADIF OF DEGREE N-1. ALSO SET NEXT HIGHER COEFFICIENT TO ZERO.
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02AHF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  PATM1, XMAX, XMIN
      INTEGER           IA1, IADIF1, IFAIL, LA, LADIF, NP1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LA), ADIF(LADIF)
C     .. Local Scalars ..
      INTEGER           IERROR, N
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          E02AHZ
C     .. Executable Statements ..
      N = NP1 - 1
      IERROR = 1
      IF ( .NOT. (NP1.GE.1 .AND. XMAX.GT.XMIN .AND. IA1.GE.1 .AND.
     *    LA.GT.N*IA1 .AND. IADIF1.GE.1 .AND. LADIF.GT.N*IADIF1))
     *    GO TO 20
      IERROR = 0
      CALL E02AHZ(NP1,XMIN,XMAX,A,IA1,LA,PATM1,ADIF,IADIF1,LADIF)
   20 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
C     END E02AHF
      END

      SUBROUTINE E02AHZ(NP1,XMIN,XMAX,A,IA1,LA,PATM1,ADIF,IADIF1,LADIF)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     NPL DATA FITTING LIBRARY ROUTINE AUXCDF
C
C     CREATED 1/5/79    UPDATED 23/1/80     RELEASE NO. 00/03
C
C     AUTHORS.. GERALD T ANTHONY, MAURICE G COX, J GEOFFREY HAYES.
C     NATIONAL PHYSICAL LABORATORY
C     TEDDINGTON, MIDDLESEX, ENGLAND.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     INPUT PARAMETERS
C        NP1    = N+1 WHERE N IS DEGREE OF GIVEN POLYNOMIAL
C        XMIN   LOWER LIMIT OF RANGE OF X
C        XMAX   UPPER LIMIT OF RANGE OF X
C        A      COEFFICIENTS A0, A1,...AN OF THE GIVEN POLYNOMIAL
C        IA1       ARE STORED IN ARRAY A IN POSITIONS 1, 1+IA1,...
C                  1+N*IA1, RESPECTIVELY
C        LA     THE DECLARED DIMENSION OF ARRAY A
C
C     OUTPUT PARAMETERS
C        PATM1  THE VALUE OF THE GIVEN POLYNOMIAL AT XMIN
C        ADIF   THE COEFFICIENTS OF THE DERIVATIVE POLYNOMIAL
C        IADIF1    ARE RETURNED IN ARRAY ADIF IN POSITIONS
C                  1, 1+IADIF1,...1+(N-1)*IADIF1
C        LADIF  THE DECLARED DIMENSION OF ARRAY ADIF
C
C     DIFFERENTIATE THE SERIES WITH COEFFICIENTS A OF DEGREE N
C     (I.E. NP1 COEFFICIENTS) TO OBTAIN THE SERIES WITH COEFFICIENTS
C     ADIF OF DEGREE N-1. ALSO SET NEXT HIGHER COEFFICIENT TO ZERO.
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  PATM1, XMAX, XMIN
      INTEGER           IA1, IADIF1, LA, LADIF, NP1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LA), ADIF(LADIF)
C     .. Local Scalars ..
      DOUBLE PRECISION  PTEMP, R, SCLFTR, TWO, U, V, W
      INTEGER           I, N, NA, NADIF
C     .. Data statements ..
      DATA              TWO/2.0D+0/
C     .. Executable Statements ..
      U = 0.0D+0
      V = U
      SCLFTR = TWO/(XMAX-XMIN)
      N = NP1 - 1
      NADIF = N*IADIF1 + 1
      PTEMP = U
      IF (N.EQ.0) GO TO 40
      NA = N*IA1 + 1
      DO 20 I = 1, N
         R = NP1 - I
         W = U + TWO*R*A(NA)
         PTEMP = A(NA) - PTEMP
C
C        STORE COEFF FORMED PREVIOUS TIME ROUND. FIRST TIME ROUND
C        STORE ZERO AS COEFF OF DEGREE N.
C
         ADIF(NADIF) = SCLFTR*V
         U = V
         V = W
         NA = NA - IA1
         NADIF = NADIF - IADIF1
   20 CONTINUE
   40 ADIF(NADIF) = SCLFTR*V
      PATM1 = A(1)/TWO - PTEMP
      RETURN
C     END OF E02AHZ
      END

      SUBROUTINE E02AJF(NP1,XMIN,XMAX,A,IA1,LA,QATM1,AIN,IAINT1,LAINT,
     *                  IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 9 REVISED. IER-315 (SEP 1981).
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     NPL DATA FITTING LIBRARY ROUTINE CHBINT
C
C     CREATED 1/5/79    UPDATED 23/1/80     RELEASE NO. 00/03
C
C     AUTHORS.. GERALD T ANTHONY, MAURICE G COX, J GEOFFREY HAYES.
C     NATIONAL PHYSICAL LABORATORY
C     TEDDINGTON, MIDDLESEX, ENGLAND.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     INPUT PARAMETERS
C        NP1    = N+1 WHERE N IS DEGREE OF GIVEN POLYNOMIAL
C        XMIN   LOWER LIMIT OF RANGE OF X
C        XMAX   UPPER LIMIT OF RANGE OF X
C        A      COEFFICIENTS A0, A1,...AN OF THE GIVEN POLYNOMIAL
C        IA1       ARE STORED IN ARRAY A IN POSITIONS 1, 1+IA1,...
C                  1+N*IA1, RESPECTIVELY
C        LA     THE DECLARED DIMENSION OF ARRAY A
C        QATM1  THE VALUE OF THE INTEGRATED POLYNOMIAL AT XMIN
C
C     OUTPUT PARAMETERS
C        AIN   THE COEFFICIENTS OF THE INTEGRATED POLYNOMIAL
C        IAINT1    ARE RETURNED IN ARRAY AIN IN POSITIONS
C                  1, 1+IAINT1,...1+NP1*IAINT1
C        LAINT  THE DECLARED DIMENSION OF ARRAY AIN
C        IFAIL  ERROR INDICATOR
C
C     INTEGRATE THE SERIES WITH COEFFICIENTS A OF DEGREE N
C     (I.E. NP1 COEFFICIENTS) TO OBTAIN THE SERIES WITH COEFFICIENTS
C     AIN OF DEGREE N + 1.  THE SUM OF THE INTEGRATED SERIES IS
C     QATM1 AT THE LEFT HAND END OF THE INTERVAL OF DEFINITION, XMIN
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02AJF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  QATM1, XMAX, XMIN
      INTEGER           IA1, IAINT1, IFAIL, LA, LAINT, NP1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LA), AIN(LAINT)
C     .. Local Scalars ..
      INTEGER           IERROR
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          E02AJZ
C     .. Executable Statements ..
      IERROR = 1
      IF ( .NOT. (NP1.GE.1 .AND. XMAX.GT.XMIN .AND. LA.GT.(NP1-1)
     *    *IA1 .AND. IA1.GE.1 .AND. IAINT1.GE.1 .AND. LAINT.GT.NP1*
     *    IAINT1)) GO TO 20
      IERROR = 0
      CALL E02AJZ(NP1,XMIN,XMAX,A,IA1,LA,QATM1,AIN,IAINT1,LAINT)
   20 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
C     END OF E02AJF
      END
      SUBROUTINE E02AJZ(NP1,XMIN,XMAX,A,IA1,LA,QATM1,AIN,IAINT1,LAINT)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 9 REVISED. IER-315 (SEP 1981).
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     NPL DATA FITTING LIBRARY ROUTINE AUXCIN
C
C     CREATED 1/5/79    UPDATED 23/1/80     RELEASE NO. 00/03
C
C     AUTHORS.. GERALD T ANTHONY, MAURICE G COX, J GEOFFREY HAYES.
C     NATIONAL PHYSICAL LABORATORY
C     TEDDINGTON, MIDDLESEX, ENGLAND.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     INPUT PARAMETERS
C        NP1    = N+1 WHERE N IS DEGREE OF GIVEN POLYNOMIAL
C        XMIN   LOWER LIMIT OF RANGE OF X
C        XMAX   UPPER LIMIT OF RANGE OF X
C        A      COEFFICIENTS A0, A1,...AN OF THE GIVEN POLYNOMIAL
C        IA1       ARE STORED IN ARRAY A IN POSITIONS 1, 1+IA1,...
C                  1+N*IA1, RESPECTIVELY
C        LA     THE DECLARED DIMENSION OF ARRAY A
C        QATM1  THE VALUE OF THE INTEGRATED POLYNOMIAL AT XMIN
C
C     OUTPUT PARAMETERS
C        AIN   THE COEFFICIENTS OF THE INTEGRATED POLYNOMIAL
C        IAINT1    ARE RETURNED IN ARRAY AIN IN POSITIONS
C                  1, 1+IAINT1,...1+NP1*IAINT1
C        LAINT  THE DECLARED DIMENSION OF ARRAY AIN
C
C     INTEGRATE THE SERIES WITH COEFFICIENTS A OF DEGREE N
C     (I.E. NP1 COEFFICIENTS) TO OBTAIN THE SERIES WITH COEFFICIENTS
C     AIN OF DEGREE N + 1.  THE SUM OF THE INTEGRATED SERIES IS
C     QATM1 AT THE LEFT HAND END OF THE INTERVAL OF DEFINITION, XMIN
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  QATM1, XMAX, XMIN
      INTEGER           IA1, IAINT1, LA, LAINT, NP1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LA), AIN(LAINT)
C     .. Local Scalars ..
      DOUBLE PRECISION  AR, ARM, ARP, R, SCLFTR, TWO, ZERO
      INTEGER           I, NA, NAINT
C     .. Data statements ..
      DATA              TWO, ZERO/2.0D+0, 0.0D+0/
C     .. Executable Statements ..
      ARP = ZERO
      AR = ARP
      SCLFTR = (XMAX-XMIN)/TWO
      NA = (NP1-1)*IA1 + 1
      NAINT = NP1*IAINT1 + 1
      DO 20 I = 1, NP1
         R = NP1 - I + 1
         ARM = A(NA)
         AIN(NAINT) = SCLFTR*(ARM-ARP)/(TWO*R)
         ARP = AR
         AR = ARM
         NA = NA - IA1
         NAINT = NAINT - IAINT1
   20 CONTINUE
C
C     FORM CONSTANT COEFF SO THAT THE VALUE OF THE INTEGRATED SERIES
C     IS QATM1 AT THE LOWER END OF THE RANGE OF THE INDEP. VARIABLE.
C
      AR = ZERO
      NAINT = NP1*IAINT1 + 1
      DO 40 I = 1, NP1
         AR = AIN(NAINT) - AR
         NAINT = NAINT - IAINT1
   40 CONTINUE
      AIN(1) = TWO*(QATM1+AR)
      RETURN
C     END OF E02AJZ
      END

      SUBROUTINE E02AKF(NP1,XMIN,XMAX,A,IA1,LA,X,RESULT,IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     NPL DATA FITTING LIBRARY ROUTINE TVAL1C
C
C     CREATED 19/3/79    UPDATED 6/7/79    RELEASE NO. 00/04.
C
C     AUTHORS.. GERALD T ANTHONY, MAURICE G COX, BETTY CURTIS
C     AND J GEOFFREY HAYES.
C     NATIONAL PHYSICAL LABORATORY
C     TEDDINGTON, MIDDLESEX, ENGLAND.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     INPUT PARAMETERS
C        NP1      NP1 = N + 1. N IS THE DEGREE OF THE
C                 CHEBYSHEV SERIES
C        XMIN     MINIMUM VALUE OF X
C        XMAX     MAXIMUM VALUE OF X
C        A        THE ARRAY WHERE THE COEFFICIENTS ARE STORED
C        IA1      THE ADDRESS INCREMENT OF A
C        LA       DIMENSION OF A
C        X        UNNORMALIZED ARGUMENT IN THE RANGE (XMIN, XMAX)
C
C     OUTPUT PARAMETERS
C        RESULT   VALUE OF THE SUMMATION
C        IFAIL    ERROR INDICATOR
C
C     NP1 CHEBYSHEV COEFFICIENTS A0, A1, ..., AN, ARE
C     STORED IN THE ARRAY A IN POSITIONS 1, 1+IA1, 1+2*IA1, ...,
C     1+N*IA1, WHERE N = NP1 - 1.
C     IA1 MUST NOT BE NEGATIVE.
C     LA MUST BE AT LEAST EQUAL TO 1 + N*IA1.
C     THE VALUE OF THE POLYNOMIAL OF DEGREE N
C     A0T0(XCAP)/2 + A1T1(XCAP) + A2T2(XCAP) + + ... + ANTN(XCAP),
C     IS CALCULATED FOR THE ARGUMENT XCAP, WHERE XCAP IS
C     THE NORMALIZED VALUE OF X IN THE RANGE (XMIN, XMAX),
C     STORING IT IN RESULT.
C     UNLESS THE ROUTINE DETECTS AN ERROR, IFAIL CONTAINS
C     ZERO ON EXIT.
C     IFAIL = 1 INDICATES AT LEAST ONE OF THE RESTRICTIONS ON
C        INPUT PARAMETERS IS VIOLATED - IE
C     NP1 .GT. 0
C     IA1 .GE. 0
C     LA .GE. 1 + N * IA1
C     XMIN .LT. XMAX
C     IFAIL = 2 INDICATES THAT
C     X DOES NOT SATISFY THE RESTRICTION XMIN .LE. X .LE. XMAX.
C     THE RECURRENCE RELATION BY CLENSHAW, MODIFIED BY REINSCH
C     AND GENTLEMAN, IS USED.
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02AKF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  RESULT, X, XMAX, XMIN
      INTEGER           IA1, IFAIL, LA, NP1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LA)
C     .. Local Scalars ..
      DOUBLE PRECISION  XCAP
      INTEGER           IERROR
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          E02AKY, E02AKZ
C     .. Executable Statements ..
      IERROR = 1
      IF (NP1.LT.1) GO TO 20
      IF (IA1.LT.1) GO TO 20
      IF (LA.LT.1+(NP1-1)*IA1) GO TO 20
      IF (XMAX.LE.XMIN) GO TO 20
      IERROR = IERROR + 1
      IF ((X.GT.XMAX) .OR. (X.LT.XMIN)) GO TO 20
      IERROR = 0
      CALL E02AKY(XMIN,XMAX,X,XCAP)
      CALL E02AKZ(NP1,A,IA1,LA,XCAP,RESULT)
   20 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
C
C     END E02AKF
C
      END
      SUBROUTINE E02AKY(XMIN,XMAX,X,XCAP)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     NPL DATA FITTING LIBRARY ROUTINE NRMLZE
C
C     CREATED 5/5/78    UPDATED 11/12/78    RELEASE NO. 00/02.
C
C     AUTHORS.. GERALD T ANTHONY, MAURICE G COX, BETTY CURTIS
C     AND J GEOFFREY HAYES.
C     NATIONAL PHYSICAL LABORATORY
C     TEDDINGTON, MIDDLESEX, ENGLAND.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     INPUT PARAMETERS
C        XMIN     MINIMUM VALUE OF X
C        XMAX     MAXIMUM VALUE OF X
C        X        UNNORMALIZED ARGUMENT IN RANGE (XMIN, XMAX)
C
C     OUTPUT PARAMETER
C        XCAP     NORMALIZED VALUE OF X
C
C     A VALUE OF X IS GIVEN, SUCH THAT
C     XMIN .LE. X .LE. XMAX.
C     XCAP IS CALCULATED SO THAT -1 .LE. X .LE. +1.
C
C     THIS FORM FOR XCAP ENSURES THAT THE COMPUTED VALUE HAS A
C     VERY SMALL ABSOLUTE ERROR.
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X, XCAP, XMAX, XMIN
C     .. Executable Statements ..
      XCAP = ((X-XMIN)-(XMAX-X))/(XMAX-XMIN)
      RETURN
C
C     END E02AKY
C
      END

      SUBROUTINE E02AKZ(NP1,A,IA1,LA,XCAP,RESULT)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     NPL DATA FITTING LIBRARY ROUTINE TVAL1
C
C     CREATED 9/5/78    UPDATED 6/4/79    RELEASE NO. 00/07.
C
C     AUTHORS.. GERALD T ANTHONY, MAURICE G COX, BETTY CURTIS
C     AND J GEOFFREY HAYES.
C     NATIONAL PHYSICAL LABORATORY
C     TEDDINGTON, MIDDLESEX, ENGLAND.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     INPUT PARAMETERS
C        NP1      NP1 = N + 1. N IS THE DEGREE OF THE
C                 CHEBYSHEV SERIES
C        A        THE ARRAY WHERE THE COEFFICIENTS ARE STORED
C        IA1      THE ADDRESS INCREMENT OF A
C        LA       DIMENSION OF A
C        XCAP     NORMALIZED ARGUMENT OF THE POLYNOMIAL
C
C     OUTPUT PARAMETER
C        RESULT   VALUE OF THE SUMMATION
C
C     NP1 CHEBYSHEV COEFFICIENTS A0, A1, ..., AN, ARE
C     STORED IN THE ARRAY A IN POSITIONS 1, 1+IA1, 1+2*IA1, ...,
C     1+N*IA1, WHERE N = NP1 - 1.
C     IA1 MUST NOT BE NEGATIVE.
C     LA MUST BE AT LEAST EQUAL TO 1 + N*IA1.
C     THE ARGUMENT XCAP IS ASSUMED TO LIE IN THE RANGE
C     -1 .LE. XCAP .LE. +1.
C     THE VALUE OF THE POLYNOMIAL OF DEGREE N
C     A0T0(XCAP)/2 + A1T1(XCAP) + A2T2(XCAP) + + ... + ANTN(XCAP),
C     IS CALCULATED FOR THE ARGUMENT XCAP STORING IT IN RESULT.
C     THE RECURRENCE RELATION BY CLENSHAW, MODIFIED BY REINSCH
C     AND GENTLEMAN, IS USED.
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  RESULT, XCAP
      INTEGER           IA1, LA, NP1
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LA)
C     .. Local Scalars ..
      DOUBLE PRECISION  AJ, BJ, CJ, FACTOR, HALF, SUM, TWO, ZERO
      INTEGER           J, JREV, N
C     .. Data statements ..
      DATA              ZERO, HALF, TWO/0.0D0, 0.5D0, 2.0D0/
C     .. Executable Statements ..
      IF (NP1.GT.1) GO TO 20
      SUM = HALF*A(1)
      GO TO 140
   20 N = NP1 - 1
      AJ = ZERO
      BJ = ZERO
      J = 1 + NP1*IA1
      IF (XCAP.GT.HALF) GO TO 100
      IF (XCAP.GE.-HALF) GO TO 60
C
C     GENTLEMANS MODIFIED RECURRENCE.
C
      FACTOR = TWO + (XCAP+XCAP)
C
C     BRACKETING NECESSARY SO AS TO AVOID ERRORS
C
      DO 40 JREV = 1, N
         J = J - IA1
         AJ = A(J) - AJ + BJ*FACTOR
         BJ = AJ - BJ
   40 CONTINUE
      SUM = HALF*A(1) - AJ + HALF*FACTOR*BJ
      GO TO 140
C
C     CLENSHAWS ORIGINAL RECURRENCE.
C
   60 FACTOR = XCAP + XCAP
      DO 80 JREV = 1, N
         J = J - IA1
         CJ = BJ
         BJ = AJ
         AJ = A(J) - CJ + BJ*FACTOR
   80 CONTINUE
      SUM = HALF*A(1) - BJ + HALF*FACTOR*AJ
      GO TO 140
C
C     REINSCHS MODIFIED RECURRENCE.
C
  100 FACTOR = TWO - (XCAP+XCAP)
C
C     BRACKETING NECESSARY IN ORDER TO AVOID ERRORS
C
      DO 120 JREV = 1, N
         J = J - IA1
         AJ = A(J) + AJ - BJ*FACTOR
         BJ = AJ + BJ
  120 CONTINUE
      SUM = HALF*A(1) + AJ - HALF*FACTOR*BJ
  140 RESULT = SUM
      RETURN
C
C     END E02AKZ
C
      END
      SUBROUTINE E02BAF(M,NCAP7,X,Y,W,K,WORK1,WORK2,C,SS,IFAIL)
C     NAG COPYRIGHT 1975
C     MARK 5 RELEASE
C     MARK 6 REVISED  IER-84
C     MARK 8 RE-ISSUE. IER-224 (APR 1980).
C     MARK 9A REVISED. IER-356 (NOV 1981)
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     NAG LIBRARY SUBROUTINE  E02BAF
C
C     E02BAF  COMPUTES A WEIGHTED LEAST-SQUARES APPROXIMATION
C     TO AN ARBITRARY SET OF DATA POINTS BY A CUBIC SPLINE
C     WITH KNOTS PRESCRIBED BY THE USER.  CUBIC SPLINE
C     INTERPOLATION CAN ALSO BE CARRIED OUT.
C
C     COX-DE BOOR METHOD FOR EVALUATING B-SPLINES WITH
C     ADAPTATION OF GENTLEMAN*S PLANE ROTATION SCHEME FOR
C     SOLVING OVER-DETERMINED LINEAR SYSTEMS.
C
C     USES NAG LIBRARY ROUTINE  P01AAF.
C
C     STARTED - 1973.
C     COMPLETED - 1976.
C     AUTHOR - MGC AND JGH.
C
C     REDESIGNED TO USE CLASSICAL GIVENS ROTATIONS IN
C     ORDER TO AVOID THE OCCASIONAL UNDERFLOW (AND HENCE
C     OVERFLOW) PROBLEMS EXPERIENCED BY GENTLEMAN*S 3-
C     MULTIPLICATION PLANE ROTATION SCHEME
C
C     WORK1  AND  WORK2  ARE WORKSPACE AREAS.
C     WORK1(R)  CONTAINS THE VALUE OF THE  R TH  DISTINCT DATA
C     ABSCISSA AND, SUBSEQUENTLY, FOR  R = 1, 2, 3, 4,  THE
C     VALUES OF THE NON-ZERO B-SPLINES FOR EACH SUCCESSIVE
C     ABSCISSA VALUE.
C     WORK2(L, J)  CONTAINS, FOR  L = 1, 2, 3, 4,  THE VALUE OF
C     THE  J TH  ELEMENT IN THE  L TH  DIAGONAL OF THE
C     UPPER TRIANGULAR MATRIX OF BANDWIDTH  4  IN THE
C     TRIANGULAR SYSTEM DEFINING THE B-SPLINE COEFFICIENTS.
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02BAF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  SS
      INTEGER           IFAIL, M, NCAP7
C     .. Array Arguments ..
      DOUBLE PRECISION  C(NCAP7), K(NCAP7), W(M), WORK1(M),
     *                  WORK2(4,NCAP7), X(M), Y(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  ACOL, AROW, CCOL, COSINE, CROW, D, D4, D5, D6,
     *                  D7, D8, D9, DPRIME, E2, E3, E4, E5, K0, K1, K2,
     *                  K3, K4, K5, K6, N1, N2, N3, RELEMT, S, SIGMA,
     *                  SINE, WI, XI
      INTEGER           I, IERROR, IPLUSJ, IU, J, JOLD, JPLUSL, JREV, L,
     *                  L4, LPLUS1, LPLUSU, NCAP, NCAP3, NCAPM1, R
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Executable Statements ..
      IERROR = 4
C     CHECK THAT THE VALUES OF  M  AND  NCAP7  ARE REASONABLE
      IF (NCAP7.LT.8 .OR. M.LT.NCAP7-4) GO TO 420
      NCAP = NCAP7 - 7
      NCAPM1 = NCAP - 1
      NCAP3 = NCAP + 3
C
C     IN ORDER TO DEFINE THE FULL B-SPLINE BASIS, AUGMENT THE
C     PRESCRIBED INTERIOR KNOTS BY KNOTS OF MULTIPLICITY FOUR
C     AT EACH END OF THE DATA RANGE.
C
      DO 20 J = 1, 4
         I = NCAP3 + J
         K(J) = X(1)
         K(I) = X(M)
   20 CONTINUE
C
C     TEST THE VALIDITY OF THE DATA.
C
C     CHECK THAT THE KNOTS ARE ORDERED AND ARE INTERIOR
C     TO THE DATA INTERVAL.
C
      IERROR = 1
      IF (K(5).LE.X(1) .OR. K(NCAP3).GE.X(M)) GO TO 420
      DO 40 J = 4, NCAP3
         IF (K(J).GT.K(J+1)) GO TO 420
   40 CONTINUE
C
C     CHECK THAT THE WEIGHTS ARE STRICTLY POSITIVE.
C
      IERROR = 2
      DO 60 I = 1, M
         IF (W(I).LE.0.0D0) GO TO 420
   60 CONTINUE
C
C     CHECK THAT THE DATA ABSCISSAE ARE ORDERED, THEN FORM THE
C     ARRAY  WORK1  FROM THE ARRAY  X.  THE ARRAY  WORK1  CONTAINS
C     THE
C     SET OF DISTINCT DATA ABSCISSAE.
C
      IERROR = 3
      WORK1(1) = X(1)
      J = 2
      DO 80 I = 2, M
         IF (X(I).LT.WORK1(J-1)) GO TO 420
         IF (X(I).EQ.WORK1(J-1)) GO TO 80
         WORK1(J) = X(I)
         J = J + 1
   80 CONTINUE
      R = J - 1
C
C     CHECK THAT THERE ARE SUFFICIENT DISTINCT DATA ABSCISSAE FOR
C     THE PRESCRIBED NUMBER OF KNOTS.
C
      IERROR = 4
      IF (R.LT.NCAP3) GO TO 420
C
C     CHECK THE FIRST  S  AND THE LAST  S  SCHOENBERG-WHITNEY
C     CONDITIONS ( S = MIN(NCAP - 1, 4) ).
C
      IERROR = 5
      DO 100 J = 1, 4
         IF (J.GE.NCAP) GO TO 160
         I = NCAP3 - J + 1
         L = R - J + 1
         IF (WORK1(J).GE.K(J+4) .OR. K(I).GE.WORK1(L)) GO TO 420
  100 CONTINUE
C
C     CHECK ALL THE REMAINING SCHOENBERG-WHITNEY CONDITIONS.
C
      IF (NCAP.LE.5) GO TO 160
      R = R - 4
      I = 4
      DO 140 J = 5, NCAPM1
         K0 = K(J+4)
         K4 = K(J)
  120    I = I + 1
         IF (WORK1(I).LE.K4) GO TO 120
         IF (I.GT.R .OR. WORK1(I).GE.K0) GO TO 420
  140 CONTINUE
C
C     INITIALISE A BAND TRIANGULAR SYSTEM (I.E. A
C     MATRIX AND A RIGHT HAND SIDE) TO ZERO. THE
C     PROCESSING OF EACH DATA POINT IN TURN RESULTS
C     IN AN UPDATING OF THIS SYSTEM. THE SUBSEQUENT
C     SOLUTION OF THE RESULTING BAND TRIANGULAR SYSTEM
C     YIELDS THE COEFFICIENTS OF THE B-SPLINES.
C
  160 DO 200 I = 1, NCAP3
         DO 180 L = 1, 4
            WORK2(L,I) = 0.0D0
  180    CONTINUE
         C(I) = 0.0D0
  200 CONTINUE
      SIGMA = 0.0D0
      J = 0
      JOLD = 0
      DO 340 I = 1, M
C
C        FOR THE DATA POINT  (X(I), Y(I))  DETERMINE AN INTERVAL
C        K(J + 3) .LE. X .LT. K(J + 4)  CONTAINING  X(I).  (IN THE
C        CASE  J + 4 .EQ. NCAP  THE SECOND EQUALITY IS RELAXED TO
C        INCLUDE
C        EQUALITY).
C
         WI = W(I)
         XI = X(I)
  220    IF (XI.LT.K(J+4) .OR. J.GT.NCAPM1) GO TO 240
         J = J + 1
         GO TO 220
  240    IF (J.EQ.JOLD) GO TO 260
C
C        SET CERTAIN CONSTANTS RELATING TO THE INTERVAL
C        K(J + 3) .LE. X .LE. K(J + 4).
C
         K1 = K(J+1)
         K2 = K(J+2)
         K3 = K(J+3)
         K4 = K(J+4)
         K5 = K(J+5)
         K6 = K(J+6)
         D4 = 1.0D0/(K4-K1)
         D5 = 1.0D0/(K5-K2)
         D6 = 1.0D0/(K6-K3)
         D7 = 1.0D0/(K4-K2)
         D8 = 1.0D0/(K5-K3)
         D9 = 1.0D0/(K4-K3)
         JOLD = J
C
C        COMPUTE AND STORE IN  WORK1(L) (L = 1, 2, 3, 4)  THE VALUES
C        OF
C        THE FOUR NORMALIZED CUBIC B-SPLINES WHICH ARE NON-ZERO AT
C        X=X(I).
C
  260    E5 = K5 - XI
         E4 = K4 - XI
         E3 = XI - K3
         E2 = XI - K2
         N1 = WI*D9
         N2 = E3*N1*D8
         N1 = E4*N1*D7
         N3 = E3*N2*D6
         N2 = (E2*N1+E5*N2)*D5
         N1 = E4*N1*D4
         WORK1(4) = E3*N3
         WORK1(3) = E2*N2 + (K6-XI)*N3
         WORK1(2) = (XI-K1)*N1 + E5*N2
         WORK1(1) = E4*N1
         CROW = Y(I)*WI
C
C        ROTATE THIS ROW INTO THE BAND TRIANGULAR SYSTEM USING PLANE
C        ROTATIONS.
C
         DO 320 LPLUS1 = 1, 4
            L = LPLUS1 - 1
            RELEMT = WORK1(LPLUS1)
            IF (RELEMT.EQ.0.0D0) GO TO 320
            JPLUSL = J + L
            L4 = 4 - L
            D = WORK2(1,JPLUSL)
            IF (ABS(RELEMT).GE.D) DPRIME = ABS(RELEMT)
     *          *SQRT(1.0D0+(D/RELEMT)**2)
            IF (ABS(RELEMT).LT.D) DPRIME = D*SQRT(1.0D0+(RELEMT/D)**2)
            WORK2(1,JPLUSL) = DPRIME
            COSINE = D/DPRIME
            SINE = RELEMT/DPRIME
            IF (L4.LT.2) GO TO 300
            DO 280 IU = 2, L4
               LPLUSU = L + IU
               ACOL = WORK2(IU,JPLUSL)
               AROW = WORK1(LPLUSU)
               WORK2(IU,JPLUSL) = COSINE*ACOL + SINE*AROW
               WORK1(LPLUSU) = COSINE*AROW - SINE*ACOL
  280       CONTINUE
  300       CCOL = C(JPLUSL)
            C(JPLUSL) = COSINE*CCOL + SINE*CROW
            CROW = COSINE*CROW - SINE*CCOL
  320    CONTINUE
         SIGMA = SIGMA + CROW**2
  340 CONTINUE
      SS = SIGMA
C
C     SOLVE THE BAND TRIANGULAR SYSTEM FOR THE B-SPLINE
C     COEFFICIENTS. IF A DIAGONAL ELEMENT IS ZERO, AND HENCE
C     THE TRIANGULAR SYSTEM IS SINGULAR, THE IMPLICATION IS
C     THAT THE SCHOENBERG-WHITNEY CONDITIONS ARE ONLY JUST
C     SATISFIED. THUS IT IS APPROPRIATE TO EXIT IN THIS
C     CASE WITH THE SAME VALUE  (IFAIL=5)  OF THE ERROR
C     INDICATOR.
C
      L = -1
      DO 400 JREV = 1, NCAP3
         J = NCAP3 - JREV + 1
         D = WORK2(1,J)
         IF (D.EQ.0.0D0) GO TO 420
         IF (L.LT.3) L = L + 1
         S = C(J)
         IF (L.EQ.0) GO TO 380
         DO 360 I = 1, L
            IPLUSJ = I + J
            S = S - WORK2(I+1,J)*C(IPLUSJ)
  360    CONTINUE
  380    C(J) = S/D
  400 CONTINUE
      IERROR = 0
  420 IF (IERROR) 440, 460, 440
  440 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
  460 IFAIL = 0
      RETURN
      END
      SUBROUTINE E02BBF(NCAP7,K,C,X,S,IFAIL)
C     NAG LIBRARY SUBROUTINE  E02BBF
C
C     E02BBF  EVALUATES A CUBIC SPLINE FROM ITS
C     B-SPLINE REPRESENTATION.
C
C     DE BOOR*S METHOD OF CONVEX COMBINATIONS.
C
C     USES NAG LIBRARY ROUTINE  P01AAF.
C
C     STARTED - 1973.
C     COMPLETED - 1976.
C     AUTHOR - MGC AND JGH.
C
C     NAG COPYRIGHT 1975
C     MARK 5 RELEASE
C     MARK 7 REVISED IER-141 (DEC 1978)
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02BBF')
C     .. Scalar Arguments ..
      DOUBLE PRECISION  S, X
      INTEGER           IFAIL, NCAP7
C     .. Array Arguments ..
      DOUBLE PRECISION  C(NCAP7), K(NCAP7)
C     .. Local Scalars ..
      DOUBLE PRECISION  C1, C2, C3, E2, E3, E4, E5, K1, K2, K3, K4, K5,
     *                  K6
      INTEGER           IERROR, J, J1, L
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. Executable Statements ..
      IERROR = 0
      IF (NCAP7.GE.8) GO TO 20
      IERROR = 2
      GO TO 120
   20 IF (X.GE.K(4) .AND. X.LE.K(NCAP7-3)) GO TO 40
      IERROR = 1
      S = 0.0D0
      GO TO 120
C
C     DETERMINE  J  SUCH THAT  K(J + 3) .LE. X .LE. K(J + 4).
C
   40 J1 = 0
      J = NCAP7 - 7
   60 L = (J1+J)/2
      IF (J-J1.LE.1) GO TO 100
      IF (X.GE.K(L+4)) GO TO 80
      J = L
      GO TO 60
   80 J1 = L
      GO TO 60
C
C     USE THE METHOD OF CONVEX COMBINATIONS TO COMPUTE  S(X).
C
  100 K1 = K(J+1)
      K2 = K(J+2)
      K3 = K(J+3)
      K4 = K(J+4)
      K5 = K(J+5)
      K6 = K(J+6)
      E2 = X - K2
      E3 = X - K3
      E4 = K4 - X
      E5 = K5 - X
      C2 = C(J+1)
      C3 = C(J+2)
      C1 = ((X-K1)*C2+E4*C(J))/(K4-K1)
      C2 = (E2*C3+E5*C2)/(K5-K2)
      C3 = (E3*C(J+3)+(K6-X)*C3)/(K6-K3)
      C1 = (E2*C2+E4*C1)/(K4-K2)
      C2 = (E3*C3+E5*C2)/(K5-K3)
      S = (E3*C2+E4*C1)/(K4-K3)
  120 IF (IERROR) 140, 160, 140
  140 IFAIL = P01ABF(IFAIL,IERROR,SRNAME,0,P01REC)
      RETURN
  160 IFAIL = 0
      RETURN
      END
      SUBROUTINE E02DEF(M,PX,PY,X,Y,LAMDA,MU,C,FF,WRK,IWRK,IFAIL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C
C     Derived from DASL routine B2VRE.
C
C     E02DEF. An algorithm for evaluating a bicubic polynomial
C     spline S(X,Y) from its B-spline representation at the M
C     points (X(I),Y(I)), I = 1, 2, ..., M.
C
C     Input Parameters:
C        M        The number of evaluation points.
C        PX       NXKNTS + 8,  where  NXKNTS  is number
C                    of interior  X-knots.
C        PY       NYKNTS + 8,  where  NYKNTS  is number
C                    of interior  Y-knots.
C        X        X-values.
C        Y        Y-values.
C        LAMDA    The X-knots.
C        MU       The Y-knots.
C        C        B-spline coefficients of  S.  First
C                    subscript relates to  X.
C
C     Output parameter:
C        FF       Values of spline.
C                 On exit, FF(I) contains the value of
C                 the spline evaluated at point (X(I),Y(I)),
C                 for I = 1,..,M.
C
C     Workspace parameters:
C        WRK      Real workspace of dimension at least (PY-4).
C        IWRK     Integer workspace of dimension at least (PY-4).
C
C     Failure indicator parameter:
C        IFAIL    Failure indicator:
C                 1 -  PX     .LT. 8,    or
C                      PY     .LT. 8,    or
C                      M      .LT. 1.
C                 2 -  E02DFW  failure for  X  or  Y.
C                 3 -  At least one point (X(K),Y(K)) lies
C                      outside the rectangle defined by
C                      LAMDA(4), LAMDA(PX-3), MU(4) and MU(PY-3).
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='E02DEF')
C     .. Scalar Arguments ..
      INTEGER           IFAIL, M, PX, PY
C     .. Array Arguments ..
      DOUBLE PRECISION  C((PX-4)*(PY-4)), FF(M), LAMDA(PX), MU(PY),
     *                  WRK(PY-4), X(M), Y(M)
      INTEGER           IWRK(PY-4)
C     .. Local Scalars ..
      DOUBLE PRECISION  XMAX, XMIN, YMAX, YMIN
      INTEGER           I, IERR, JERROR, K, NREC, NXKNTS, NYKNTS
C     .. Local Arrays ..
      CHARACTER*80      REC(3)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          E02DEZ, E02DFW
C     .. Executable Statements ..
      IERR = 0
      NREC = 0
      IF (M.LT.1 .OR. PX.LT.8 .OR. PY.LT.8) THEN
         IERR = 1
         NREC = 2
         WRITE (REC,FMT=99999) M, PX, PY
      ELSE
C        NXKNTS and NYKNTS are the number of interior knots in the
C        X and Y directions respectively.
         NXKNTS = PX - 8
         NYKNTS = PY - 8
C        Check X and Y knot sets.
         XMIN = LAMDA(4)
         XMAX = LAMDA(PX-3)
         YMIN = MU(4)
         YMAX = MU(PY-3)
         CALL E02DFW(PX,XMIN,XMAX,LAMDA,PX,JERROR)
         IF (JERROR.NE.0) THEN
            IERR = 2
            NREC = 1
            WRITE (REC,FMT=99998) 'LAMDA'
         ELSE
            CALL E02DFW(PY,YMIN,YMAX,MU,PY,JERROR)
            IF (JERROR.NE.0) THEN
               IERR = 2
               NREC = 1
               WRITE (REC,FMT=99998) 'MU'
            ELSE
C              Check that all points lie inside the spline domain.
               K = 0
               DO 20 I = M, 1, -1
                  IF (X(I).LT.LAMDA(4) .OR. X(I).GT.LAMDA(PX-3)
     *                .OR. Y(I).LT.MU(4) .OR. Y(I).GT.MU(PY-3)) THEN
                     K = I
                  END IF
   20          CONTINUE
               IF (K.GT.0) THEN
                  IERR = 3
                  NREC = 3
                  WRITE (REC,FMT=99997) K, X(K), Y(K)
               ELSE
C                 Evaluate S(X,Y) at all specified points.
                  CALL E02DEZ(M,NXKNTS,XMIN,XMAX,LAMDA,PX,NYKNTS,YMIN,
     *                        YMAX,MU,PY,C,PY-4,1,(PY-4)*(PX-4),X,Y,FF,
     *                        WRK,IWRK)
               END IF
            END IF
         END IF
      END IF
      IFAIL = P01ABF(IFAIL,IERR,SRNAME,NREC,REC)
      RETURN
C
99999 FORMAT (1X,'** On entry, either M.lt.1, PX.lt.8 or PY.lt.8:',/4X,
     *       'M =',I16,', PX =',I16,', PY =',I16,'.')
99998 FORMAT (1X,'** On entry, the knots in ',A,' are not in non-decre',
     *       'asing order.')
99997 FORMAT (1X,'** On entry, point (X(K),Y(K)) lies outside the rect',
     *       'angle bounded by',/4X,'LAMDA(4), LAMDA(PX-3), MU(4), MU(',
     *       'PY-3):',/4X,'K =',I8,', X(K) = ',1P,D13.5,', Y(K) = ',
     *       D13.5,' .')
      END
      SUBROUTINE E02DEZ(M,NXKNTS,XMIN,XMAX,XLAM,LXLAM,NYKNTS,YMIN,YMAX,
     *                  YLAM,LYLAM,C,IC1,IC2,LC,X,Y,S,YDEP,IYBSI)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     Chopped from DASL routine B2VR0.
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         (ZERO=0.0D+0)
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN, YMAX, YMIN
      INTEGER           IC1, IC2, LC, LXLAM, LYLAM, M, NXKNTS, NYKNTS
C     .. Array Arguments ..
      DOUBLE PRECISION  C(LC), S(M), X(M), XLAM(LXLAM), Y(M),
     *                  YDEP(LYLAM-4), YLAM(LYLAM)
      INTEGER           IYBSI(LYLAM-4)
C     .. Local Scalars ..
      DOUBLE PRECISION  T
      INTEGER           IC, IND, IXBAS, IYBAS, J, JSTOP, JSTRT, JXINT,
     *                  JYINT, K, NINDEX
C     .. Local Arrays ..
      DOUBLE PRECISION  XBASIS(4), YBASIS(4)
      INTEGER           IYINT(1)
C     .. External Subroutines ..
      EXTERNAL          E01DAV, E02DFV, E02DFX
C     .. Executable Statements ..
      DO 80 K = 1, M
C        Determine (i) the set of interval indices
C        corresponding to the specified Y-value, and (ii) the
C        indices of B-splines which contain within their
C        support the intervals specified by the interval
C        indices in (i), and the number of such indices.
         CALL E02DFX(4,NYKNTS+4,YLAM(5),LYLAM-4,YMAX,1,Y(K),IYINT,
     *               NINDEX,IYBSI)
         JYINT = IYINT(1)
C        Form the non-zero B-spline basis values (in Y) for
C        each specified  Y-value.
         CALL E01DAV(4,YLAM(JYINT+1),8,Y(K),YBASIS)
C        Determine the interval index corresponding to X(K).
         CALL E02DFV(NXKNTS,XLAM(5),LXLAM-4,XMAX,X(K),JXINT)
C        Form the non-zero B-spline basis values (in X) at X(K).
         CALL E01DAV(4,XLAM(JXINT+1),8,X(K),XBASIS)
C        Form in YDEP all Y-dependent parts of the bivariate spline
C        needed in computing the required value of S(X,Y) at X = X(K).
         DO 40 IND = 1, NINDEX
            J = IYBSI(IND)
            IC = 1 + (JXINT-1)*IC1 + (J-1)*IC2
            T = ZERO
            DO 20 IXBAS = 1, 4
               IC = IC + IC1
               T = T + XBASIS(IXBAS)*C(IC)
   20       CONTINUE
            YDEP(J) = T
   40    CONTINUE
C        Finally form the value of S(X(K),Y(K)).
         IYBAS = 0
         JSTRT = JYINT + 1
         JSTOP = JYINT + 4
         T = ZERO
         DO 60 J = JSTRT, JSTOP
            IYBAS = IYBAS + 1
            T = T + YBASIS(IYBAS)*YDEP(J)
   60    CONTINUE
         S(K) = T
   80 CONTINUE
      RETURN
      END
      SUBROUTINE E02DFV(NKNOTS,LAMBDA,LLMBDA,XMAX,X,JINTVL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, modified to allow any number of interior
C     knots equal to XMAX. XMAX is an added argument.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE INTVL     INTERVAL SEARCH FOR THE SPLINE
C     ================     SUBINTERVAL CONTAINING  X
C
C     CREATED 13 06 79.  UPDATED 23 06 82.  RELEASE 00/05
C
C     AUTHORS ... DEREK BUSH, MAURICE G. COX, PAULINE E. M.
C                 CURTIS AND J. GEOFFREY HAYES
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX  TW11 0LW, ENGLAND
C
C     (C)  CROWN COPYRIGHT 1979-1982
C
C     **********************************************************
C
C     INTVL.  CALCULATES  JINTVL,  THE SPLINE
C     INTERVAL WITHIN WHICH  X  LIES.
C
C        IF X = XMAX, THEN JINTVL IS RETURNED AS THE RIGHTMOST
C        NON-ZERO INTERVAL SUCH THAT LAMBDA(JINTVL) .LT.
C        LAMBDA(JINTVL+1). OTHERWISE,
C        JINTVL = 0       FOR  X .LT. LAMBDA(1),
C        JINTVL = NKNOTS  FOR LAMBDA(NKNOTS) .LE. X,
C        OTHERWISE  JINTVL  IS SUCH THAT
C           LAMBDA(JINTVL) .LE. X .LT. LAMBDA(JINTVL + 1).
C
C     INPUT PARAMETERS
C        NKNOTS   NUMBER OF INTERIOR KNOTS
C        LAMBDA   INTERIOR KNOTS
C        LLMBDA   DIMENSION OF LAMBDA
C        X        ABSCISSA VALUE
C
C     INPUT/OUTPUT PARAMETER
C        JINTVL   INTERVAL INDEX ASSOCIATED WITH  X
C
C     ----------------------------------------------------------
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X, XMAX
      INTEGER           JINTVL, LLMBDA, NKNOTS
C     .. Array Arguments ..
      DOUBLE PRECISION  LAMBDA(LLMBDA)
C     .. Local Scalars ..
      INTEGER           JTEMP
C     .. External Subroutines ..
      EXTERNAL          E01DAP
C     .. Executable Statements ..
C
C     DISPENSE FIRST WITH THE CASES WHERE THERE ARE NO KNOTS,
C     WHERE  X .LT. LAMBDA(1),  WHERE  X .GE. LAMBDA(NKNOTS)
C
      JTEMP = 0
      IF (NKNOTS.EQ.0) GO TO 40
      IF (X.LT.LAMBDA(1)) GO TO 40
      JTEMP = NKNOTS
C
C     This routine has been modified by the addition of the next
C     seven lines, to allow interior knots to be equal to XMAX.
C     If on entry X = XMAX, we have to return JINTVL as the nearest
C     non-zero interval to the left.
      IF (X.EQ.XMAX) THEN
   20    IF (LAMBDA(JTEMP).EQ.XMAX) THEN
            JTEMP = JTEMP - 1
            IF (JTEMP.GT.0) GO TO 20
         END IF
         GO TO 40
      END IF
C
      IF (X.GE.LAMBDA(NKNOTS)) GO TO 40
      JTEMP = JINTVL
C
C     DETERMINE THE SPLINE SUBINTERVAL INDEX IN THE
C     GENERAL CASE
C
      IF (JTEMP.EQ.NKNOTS) JTEMP = NKNOTS - 1
      IF (JTEMP.EQ.0) JTEMP = 1
      IF ( .NOT. (LAMBDA(JTEMP).LE.X .AND. X.LT.LAMBDA(JTEMP+1)))
     *    CALL E01DAP(NKNOTS,LAMBDA,X,JTEMP)
   40 JINTVL = JTEMP
      RETURN
C
C     END E02DFV
C
      END
      SUBROUTINE E02DFW(NKNOTS,XMIN,XMAX,LAMBDA,LLMBDA,IFAIL)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A modified DASL routine.
C     Originally was called for checks on interior knots only.
C     Modified so that exterior as well as interior knots are
C     passed in LAMDA and checked for monotonicity.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE CHKNOT    CHECK SPLINE INTERVAL AND
C     =================    INTERIOR KNOTS FOR NONPERIODIC
C                          SPLINE
C
C     CREATED 08 05 79.  UPDATED 21 06 82.  RELEASE 00/05
C
C     AUTHORS ... MAURICE G. COX, PAULINE E. M. CURTIS AND
C                 J. GEOFFREY HAYES
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX  TW11 0LW, ENGLAND
C
C     (C)  CROWN COPYRIGHT 1979-1982
C
C     **********************************************************
C
C     E02DFW.  AN ALGORITHM FOR CHECKING A SET OF CONDITIONS
C     RELATING TO A GIVEN SPLINE INTERVAL AND ITS INTERIOR
C     KNOTS
C
C     INPUT PARAMETERS
C        NKNOTS   NUMBER OF INTERIOR AND EXTERIOR KNOTS
C        XMIN,
C        XMAX     LOWER AND UPPER ENDPOINTS OF INTERVAL
C        LAMBDA   INTERIOR AND EXTERIOR KNOTS
C        LLMBDA   DIMENSION OF LAMBDA
C
C     FAILURE INDICATOR PARAMETER
C        IFAIL    FAILURE INDICATOR
C                    1 - AT LEAST ONE OF THE FOLLOWING
C                        RESTRICTIONS HAS BEEN VIOLATED.
C                           NKNOTS .GE. 8,
C                           LLMBDA .GE. NKNOTS
C                           XMIN .LT. XMAX,
C                           XMIN .LT. LAMBDA(5)
C                                 (IF  NKNOTS .GT. 8),
C                           LAMBDA(NKNOTS-4) .LT. XMAX
C                                 (IF  NKNOTS .GT. 8),
C                           LAMBDA(J - 1) .LE. LAMBDA(J),
C                              FOR J = 2, 3, ..., NKNOTS
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX, XMIN
      INTEGER           IFAIL, LLMBDA, NKNOTS
C     .. Array Arguments ..
      DOUBLE PRECISION  LAMBDA(LLMBDA)
C     .. Local Scalars ..
      INTEGER           IERROR, J
C     .. Executable Statements ..
C
      IERROR = 1
C
C     CHECK THAT THERE IS A NONNEGATIVE NUMBER OF INTERIOR
C     KNOTS
C
      IF (NKNOTS.LT.8) GO TO 60
C
C     CHECK THAT THE UPPER ENDPOINT IS GREATER THAN THE
C     LOWER ENDPOINT
C
      IF (XMAX.LE.XMIN) GO TO 60
C
C     CHECK THAT THE ARRAY  LAMBDA  IS LARGE ENOUGH
C     TO ACCOMMODATE THE NUMBER OF KNOTS.
C
      IF (LLMBDA.LT.NKNOTS) GO TO 60
C
C     IF THERE ARE NO INTERIOR KNOTS THEN IT IS
C     NOT NECESSARY TO CARRY OUT THE REMAINING CHECKS.
C
      IF (NKNOTS.EQ.8) GO TO 40
C
C     CHECK THAT THE LOWER ENDPOINT OF THE RANGE IS LESS
C     THAN THE FIRST INTERIOR KNOT.
C
      IF (LAMBDA(5).LE.XMIN) GO TO 60
C
C     CHECK THAT THE UPPER ENDPOINT OF THE RANGE IS
C     GREATER THAN THE LAST KNOT.
C
      IF (XMAX.LE.LAMBDA(NKNOTS-4)) GO TO 60
C
C     CHECK THAT THE KNOT SET IS NOT DECREASING
C
      DO 20 J = 2, NKNOTS
         IF (LAMBDA(J).LT.LAMBDA(J-1)) GO TO 60
   20 CONTINUE
   40 IERROR = 0
   60 IFAIL = IERROR
      RETURN
C
C     END E02DFW
C
      END
      SUBROUTINE E02DFX(NORDER,Q,LAMBDA,LLMBDA,XMAX,M,X,JINTVL,NINDEX,
     *                  INDEX)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C     A DASL routine, unmodified except for name.
C
C     **********************************************************
C
C     D A S L  -  DATA APPROXIMATION SUBROUTINE LIBRARY
C
C     SUBROUTINE BINDEX      INTERVAL INDICES AND B-SPLINE
C     =================      INDICES FOR SPECIFIED POINT SET
C
C     CREATED 23 07 79.  UPDATED 25 11 82.  RELEASE 00/03
C
C     AUTHORS ... MAURICE G. COX AND PAULINE E. M. CURTIS.
C     NATIONAL PHYSICAL LABORATORY, TEDDINGTON,
C     MIDDLESEX TW11 OLW, ENGLAND.
C
C     (C)  CROWN COPYRIGHT 1980-1982
C
C     **********************************************************
C
C     E02DFX.   GIVEN AN ORDER, A SET OF KNOTS, AND A SET OF
C     STRICTLY INCREASING  X-VALUES,  E02DFX  DETERMINES
C        (1) THE SET OF INTERVAL INDICES CORRESPONDING TO
C            THESE X-VALUES,
C        (2) THE SET OF DISTINCT B-SPLINE INDICES WHICH
C            CONTAIN WITHIN THEIR SUPPORT THE INTERVALS
C            SPECIFIED BY THE INTERVAL INDICES IN (1)
C
C     INPUT PARAMETERS
C        NORDER   ORDER (DEGREE + 1) OF SPLINE
C        Q        NKNOTS + NORDER, WHERE NKNOTS IS NUMBER OF
C                    INTERIOR KNOTS
C        LAMBDA   INTERIOR KNOTS
C        LLMBDA   DIMENSION OF LAMBDA
C        M        NUMBER OF VALUES OF INDEPENDENT VARIABLE
C        X        INDEPENDENT VARIABLE VALUES
C
C     OUTPUT PARAMETERS
C        JINTVL   INTERVAL INDICES CORRESPONDING TO X-VALUES
C        NINDEX   NUMBER OF DISTINCT B-SPLINE INDICES
C        INDEX    SET OF DISTINCT B-SPLINE INDICES IN
C                    INDEX(1)  TO  INDEX(NINDEX).  REMAINING
C                    ELEMENTS UNUSED.
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION  XMAX
      INTEGER           LLMBDA, M, NINDEX, NORDER, Q
C     .. Array Arguments ..
      DOUBLE PRECISION  LAMBDA(LLMBDA), X(M)
      INTEGER           INDEX(Q), JINTVL(M)
C     .. Local Scalars ..
      INTEGER           I, IMAX, IP, J, K, L, LAST, NKNOTS, NOW, P
C     .. External Subroutines ..
      EXTERNAL          E02DFV
C     .. Intrinsic Functions ..
      INTRINSIC         MIN
C     .. Executable Statements ..
C
      NKNOTS = Q - NORDER
C
C     DETERMINE FIRST THE SET OF  M  INTERVAL INDICES
C
      J = 0
      DO 20 I = 1, M
         CALL E02DFV(NKNOTS,LAMBDA,LLMBDA,XMAX,X(I),J)
         JINTVL(I) = J
   20 CONTINUE
C
C     NOW PROVIDE THE SET  J  OF DISTINCT B-SPLINE INDICES
C     AND THEIR NUMBER.  J  IS GIVEN BY THE UNION OF THE
C     INTEGER SETS  JINTVL(I) + 1, JINTVL(I) + 2, ... ,
C     JINTVL(I) + NORDER,  FOR  I = 1, 2, ..., M
C     FOR  I = 1, 2, ... , M .
C
      K = 0
      NOW = -NORDER
      IMAX = 0
      DO 60 I = 1, M
         LAST = NOW
         NOW = JINTVL(I)
         IF (NOW.EQ.LAST) GO TO 60
         P = MIN(NOW-LAST,NORDER)
         L = NOW + NORDER - P
         DO 40 IP = 1, P
            K = K + 1
            L = L + 1
            INDEX(K) = L
   40    CONTINUE
         IMAX = IMAX + P
   60 CONTINUE
      NINDEX = IMAX
      RETURN
C
C     END E02DFX
C
      END

      SUBROUTINE F01BRQ(N,ICN,A,LICN,LENR,LENRL,W)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MC24A
C
C     OBTAINS AN ESTIMATE OF THE LARGEST ELEMENT ENCOUNTERED DURING
C     GAUSSIAN ELIMINATION ON A SPARSE MATRIX FROM THE LU FACTORS
C     OBTAINED.
C
C     .. Scalar Arguments ..
      INTEGER           LICN, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LICN), W(N)
      INTEGER           ICN(LICN), LENR(N), LENRL(N)
C     .. Local Scalars ..
      DOUBLE PRECISION  AMAXL, AMAXU, WROWL, ZERO
      INTEGER           I, J, J0, J1, J2, JJ
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX
C     .. Data statements ..
      DATA              ZERO/0.0D0/
C     .. Executable Statements ..
      AMAXL = ZERO
      DO 20 I = 1, N
         W(I) = ZERO
   20 CONTINUE
      J0 = 1
      DO 120 I = 1, N
         IF (LENR(I).EQ.0) GO TO 120
         J2 = J0 + LENR(I) - 1
         IF (LENRL(I).EQ.0) GO TO 60
C        CALCULATION OF 1-NORM OF L.
         J1 = J0 + LENRL(I) - 1
         WROWL = ZERO
         DO 40 JJ = J0, J1
C           AMAXL IS THE MAXIMUM NORM OF COLUMNS OF L SO FAR FOUND.
            WROWL = WROWL + ABS(A(JJ))
   40    CONTINUE
         AMAXL = MAX(AMAXL,WROWL)
         J0 = J1 + 1
C        CALCULATION OF NORMS OF COLUMNS OF U (MAX-NORMS).
   60    J0 = J0 + 1
         IF (J0.GT.J2) GO TO 100
         DO 80 JJ = J0, J2
            J = ICN(JJ)
            W(J) = MAX(ABS(A(JJ)),W(J))
   80    CONTINUE
  100    J0 = J2 + 1
  120 CONTINUE
C     AMAXU IS SET TO MAXIMUM MAX-NORM OF COLUMNS OF U.
      AMAXU = ZERO
      DO 140 I = 1, N
         AMAXU = MAX(AMAXU,W(I))
  140 CONTINUE
C     GROFAC IS MAX U MAX-NORM TIMES MAX L 1-NORM.
      W(1) = AMAXL*AMAXU
      RETURN
      END
      SUBROUTINE F01BRR(N,ICN,A,NZ,LENROW,IP,IQ,IW,IW1)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MC22A
C
C     REPLACES A SPARSE MATRIX  A  BY THE PERMUTED MATRIX  P*A*Q ,
C     WHERE  P  AND  Q  ARE PERMUTATION MATRICES.
C
C     .. Scalar Arguments ..
      INTEGER           N, NZ
C     .. Array Arguments ..
      DOUBLE PRECISION  A(NZ)
      INTEGER           ICN(NZ), IP(N), IQ(N), IW(N,2), IW1(NZ),
     *                  LENROW(N)
C     .. Local Scalars ..
      DOUBLE PRECISION  AVAL
      INTEGER           I, ICHAIN, IOLD, IPOS, J, J2, JJ, JNUM, JVAL,
     *                  LENGTH, NEWPOS
C     .. Intrinsic Functions ..
      INTRINSIC         ABS
C     .. Executable Statements ..
      IF (NZ.LE.0) GO TO 180
      IF (N.LE.0) GO TO 180
C     SET START OF ROW I IN IW(I,1) AND LENROW(I) IN IW(I,2)
      IW(1,1) = 1
      IW(1,2) = LENROW(1)
      DO 20 I = 2, N
         IW(I,1) = IW(I-1,1) + LENROW(I-1)
         IW(I,2) = LENROW(I)
   20 CONTINUE
C     PERMUTE LENROW ACCORDING TO IP.  SET OFF-SETS FOR NEW
C     POSITION OF ROW IOLD IN IW(IOLD,1) AND PUT OLD ROW INDICES
C     IN IW1 IN POSITIONS CORRESPONDING TO THE NEW POSITION OF
C     THIS ROW IN A/ICN.
      JJ = 1
      DO 60 I = 1, N
         IOLD = IP(I)
         IOLD = ABS(IOLD)
         LENGTH = IW(IOLD,2)
         LENROW(I) = LENGTH
         IF (LENGTH.EQ.0) GO TO 60
         IW(IOLD,1) = IW(IOLD,1) - JJ
         J2 = JJ + LENGTH - 1
         DO 40 J = JJ, J2
            IW1(J) = IOLD
   40    CONTINUE
         JJ = J2 + 1
   60 CONTINUE
C     SET INVERSE PERMUTATION TO IQ IN IW(.,2).
      DO 80 I = 1, N
         IOLD = IQ(I)
         IOLD = ABS(IOLD)
         IW(IOLD,2) = I
   80 CONTINUE
C     PERMUTE A AND ICN IN PLACE, CHANGING TO NEW COLUMN NUMBERS.
C
C     ***   MAIN LOOP   ***
C     EACH PASS THROUGH THIS LOOP PLACES A CLOSED CHAIN OF COLUMN
C     INDICES IN THEIR NEW (AND FINAL) POSITIONS ... THIS IS
C     RECORDED BY SETTING THE IW1 ENTRY TO ZERO SO THAT ANY WHICH
C     ARE SUBSEQUENTLY ENCOUNTERED DURING THIS MAJOR SCAN CAN BE
C     BYPASSED.
      DO 160 I = 1, NZ
         IOLD = IW1(I)
         IF (IOLD.EQ.0) GO TO 160
         IPOS = I
         JVAL = ICN(I)
C        IF ROW IOLD IS IN SAME POSITIONS AFTER PERMUTATION GO TO ...
         IF (IW(IOLD,1).EQ.0) GO TO 140
         AVAL = A(I)
C        **  CHAIN LOOP  **
C        EACH PASS THROUGH THIS LOOP PLACES ONE (PERMUTED) COLUMN
C        INDEX IN ITS FINAL POSITION  .. VIZ. IPOS.
         DO 100 ICHAIN = 1, NZ
C           NEWPOS IS THE ORIGINAL POSITION IN A/ICN OF THE ELEMENT
C           TO BE PLACED IN POSITION IPOS.  IT IS ALSO THE POSITION
C           OF THE NEXT ELEMENT INTHE CHAIN.
            NEWPOS = IPOS + IW(IOLD,1)
C           IS CHAIN COMPLETE ...
            IF (NEWPOS.EQ.I) GO TO 120
            A(IPOS) = A(NEWPOS)
            JNUM = ICN(NEWPOS)
            ICN(IPOS) = IW(JNUM,2)
            IPOS = NEWPOS
            IOLD = IW1(IPOS)
            IW1(IPOS) = 0
C           **  END OF CHAIN LOOP  **
  100    CONTINUE
  120    A(IPOS) = AVAL
  140    ICN(IPOS) = IW(JVAL,2)
C        ***  END OF MAIN LOOP   ***
  160 CONTINUE
C
  180 RETURN
      END
      SUBROUTINE F01BRS(A,ICN,IPTR,N,IACTIV,ITOP,REALS,IUP)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MA30D
C
C     COLLECTS GARBAGE IN ARRAYS, COMPRESSING THE USEFUL
C     INFORMATION TO THE TOP END OF THE ARRAY AND FREEING THE
C     EARLIER LOCATIONS FOR WORKSPACE OR SUBSEQUENT STORAGE.
C
C     IF REALS=TRUE, F01BRS MUST BE CALLED WITH ICNCP AS IUP.
C     IF REALS=FALSE, F01BRS MUST BE CALLED WITH IRNCP AS IUP.
C     IACTIV IS THE FIRST POSITION IN ARRAYS A/ICN FROM WHICH THE
C     COMPRESS STARTS.
C     ON EXIT IACTIV EQUALS THE POSITION OF THE FIRST ELEMENT IN
C     THE COMPRESSED PART OF A/ICN
C     .. Scalar Arguments ..
      INTEGER           IACTIV, ITOP, IUP, N
      LOGICAL           REALS
C     .. Array Arguments ..
      DOUBLE PRECISION  A(ITOP)
      INTEGER           ICN(ITOP), IPTR(N)
C     .. Local Scalars ..
      INTEGER           J, JPOS, K, KL, KN
C     .. Executable Statements ..
      IUP = IUP + 1
C     SET THE FIRST NON-ZERO ELEMENT IN EACH ROW TO THE NEGATIVE OF
C     THE ROW/COL NUMBER AND HOLD THIS ROW/COL INDEX IN THE ROW/COL
C     POINTER.  THIS IS SO THAT THE BEGINNING OF EACH ROW/COL CAN
C     BE RECOGNIZED IN THE SUBSEQUENT SCAN.
      DO 20 J = 1, N
         K = IPTR(J)
         IF (K.LT.IACTIV) GO TO 20
         IPTR(J) = ICN(K)
         ICN(K) = -J
   20 CONTINUE
      KN = ITOP + 1
      KL = ITOP - IACTIV + 1
C     GO THROUGH ARRAYS IN REVERSE ORDER COMPRESSING TO THE BACK SO
C     THAT THERE ARE NO ZEROS HELD IN POSITIONS IACTIV TO ITOP IN
C     ICN.
C     RESET FIRST ELEMENT OF EACH ROW/COL AND POINTER ARRAY IPTR.
      DO 60 K = 1, KL
         JPOS = ITOP - K + 1
         IF (ICN(JPOS).EQ.0) GO TO 60
         KN = KN - 1
         IF (REALS) A(KN) = A(JPOS)
         IF (ICN(JPOS).GE.0) GO TO 40
C        FIRST NON-ZERO OF ROW/COL HAS BEEN LOCATED
         J = -ICN(JPOS)
         ICN(JPOS) = IPTR(J)
         IPTR(J) = KN
   40    ICN(KN) = ICN(JPOS)
   60 CONTINUE
      IACTIV = KN
      RETURN
      END
      SUBROUTINE F01BRU(N,ICN,LICN,IP,LENR,ARP,IB,NUM,LOWL,NUMB,PREV)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MC13E
C
C     FINDS A SYMMETRIC PERMUTATION WHICH PERMUTES A SPARSE MATRIX
C     TO BLOCK LOWER TRIANGULAR FORM, GIVEN THE COLUMN NUMBERS OF
C     THE NON-ZEROS IN EACH ROW OF THE MATRIX.
C
C     ARP(I) IS ONE LESS THAN THE NUMBER OF UNSEARCHED EDGES
C     .     LEAVING NODE I.  AT THE END OF THE ALGORITHM IT IS SET
C     .     TO A PERMUTATION WHICH PUTS THE MATRIX IN BLOCK LOWER
C     .     TRIANGULAR FORM.
C     IB(I) IS THE POSITION IN THE ORDERING OF THE START OF THE ITH
C     .     BLOCK.  IB(N+1-I) HOLDS THE NODE NUMBER OF THE ITH NODE
C     .     ON THE STACK.
C     LOWL(I) IS THE SMALLEST STACK POSITION OF ANY NODE TO WHICH A
C     .     PATH FROM  HAS BEEN FOUND.  IT IS SET TO N+1 WHEN NODE I
C     .     IS REMOVED FROM THE STACK.
C     NUMB(I) IS THE POSITION OF NODE I IN THE STACK IF IT IS ON
C     .     IT, IS THE PERMUTED ORDER OF NODE I FOR THOSE NODES
C     .     WHOSE FINAL POSITION HAS BEEN FOUND AND IS OTHERWISE
C     .     ZERO.
C     PREV(I) IS THE NODE AT THE END OF THE PATH WHEN NODE I WAS
C     .     PLACED ON THE STACK.
C
C
C     ICNT IS THE NUMBER OF NODES WHOSE POSITIONS IN FINAL ORDERING
C     HAVE BEEN FOUND.
C     .. Scalar Arguments ..
      INTEGER           LICN, N, NUM
C     .. Array Arguments ..
      INTEGER           ARP(N), IB(N), ICN(LICN), IP(N), LENR(N),
     *                  LOWL(N), NUMB(N), PREV(N)
C     .. Local Scalars ..
      INTEGER           DUMMY, I, I1, I2, ICNT, II, ISN, IST, IST1, IV,
     *                  IW, J, K, LCNT, NNM1, STP
C     .. Intrinsic Functions ..
      INTRINSIC         MIN
C     .. Executable Statements ..
      ICNT = 0
C     NUM IS THE NUMBER OF BLOCKS THAT HAVE BEEN FOUND.
      NUM = 0
      NNM1 = N + N - 1
C
C     INITIALIZATION OF ARRAYS.
      DO 20 J = 1, N
         NUMB(J) = 0
         ARP(J) = LENR(J) - 1
   20 CONTINUE
C
      DO 180 ISN = 1, N
C        LOOK FOR A STARTING NODE
         IF (NUMB(ISN).NE.0) GO TO 180
         IV = ISN
C        IST IS THE NUMBER OF NODES ON THE STACK ... IT IS THE STACK
C        POINTER.
         IST = 1
C        PUT NODE IV AT BEGINNING OF STACK.
         LOWL(IV) = 1
         NUMB(IV) = 1
         IB(N) = IV
C
C        THE BODY OF THIS LOOP PUTS A NEW NODE ON THE STACK OR
C        BACKTRACKS.
         DO 160 DUMMY = 1, NNM1
            I1 = ARP(IV)
C           HAVE ALL EDGES LEAVING NODE IV BEEN SEARCHED.
            IF (I1.LT.0) GO TO 60
            I2 = IP(IV) + LENR(IV) - 1
            I1 = I2 - I1
C
C           LOOK AT EDGES LEAVING NODE IV UNTIL ONE ENTERS A NEW NODE OR
C           ALL EDGES ARE EXHAUSTED.
            DO 40 II = I1, I2
               IW = ICN(II)
C              HAS NODE IW BEEN ON STACK ALREADY.
               IF (NUMB(IW).EQ.0) GO TO 140
C              UPDATE VALUE OF LOWL(IV) IF NECESSARY.
               LOWL(IV) = MIN(LOWL(IV),LOWL(IW))
   40       CONTINUE
C
C           THERE ARE NO MORE EDGES LEAVING NODE IV.
            ARP(IV) = -1
C           IS NODE IV THE ROOT OF A BLOCK.
   60       IF (LOWL(IV).LT.NUMB(IV)) GO TO 120
C
C           ORDER NODES IN A BLOCK.
            NUM = NUM + 1
            IST1 = N + 1 - IST
            LCNT = ICNT + 1
C           PEEL BLOCK OFF THE TOP OF THE STACK STARTING AT THE TOP AND
C           WORKING DOWN TO THE ROOT OF THE BLOCK.
            DO 80 STP = IST1, N
               IW = IB(STP)
               LOWL(IW) = N + 1
               ICNT = ICNT + 1
               NUMB(IW) = ICNT
               IF (IW.EQ.IV) GO TO 100
   80       CONTINUE
  100       IST = N - STP
            IB(NUM) = LCNT
C           ARE THERE ANY NODES LEFT ON THE STACK.
            IF (IST.NE.0) GO TO 120
C           HAVE ALL THE NODES BEEN ORDERED.
            IF (ICNT.LT.N) GO TO 180
            GO TO 200
C
C           BACKTRACK TO PREVIOUS NODE ON PATH.
  120       IW = IV
            IV = PREV(IV)
C           UPDATE VALUE OF LOWL(IV) IF NECESSARY.
            LOWL(IV) = MIN(LOWL(IV),LOWL(IW))
            GO TO 160
C
C           PUT NEW NODE ON THE STACK.
  140       ARP(IV) = I2 - II - 1
            PREV(IW) = IV
            IV = IW
            IST = IST + 1
            LOWL(IV) = IST
            NUMB(IV) = IST
            K = N + 1 - IST
            IB(K) = IV
  160    CONTINUE
  180 CONTINUE
C
C     PUT PERMUTATION IN THE REQUIRED FORM.
  200 DO 220 I = 1, N
         II = NUMB(I)
         ARP(II) = I
  220 CONTINUE
      RETURN
      END
      SUBROUTINE F01BRV(N,ICN,LICN,IP,LENR,IOR,IB,NUM,IW)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MC13D
C
C     INTERFACE FOR F01BRV
C
C     .. Scalar Arguments ..
      INTEGER           LICN, N, NUM
C     .. Array Arguments ..
      INTEGER           IB(N), ICN(LICN), IOR(N), IP(N), IW(N,3),
     *                  LENR(N)
C     .. External Subroutines ..
      EXTERNAL          F01BRU
C     .. Executable Statements ..
      CALL F01BRU(N,ICN,LICN,IP,LENR,IOR,IB,NUM,IW(1,1),IW(1,2),IW(1,3))
      RETURN
      END
      SUBROUTINE F01BRW(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,PR,PREORD,ARP,CV,
     *                  OUT,NP1)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MC21B
C
C     FINDS A ROW PERMUTATION OF A SPARSE MATRIX THAT MAKES ALL THE
C     DIAGONAL ELEMENTS NON-ZERO (OR AS MANY OF THEM AS POSSIBLE),
C     GIVEN THE PATTERN OF NON-ZEROS.
C
C     PR(I) IS THE PREVIOUS ROW TO I IN THE DEPTH FIRST SEARCH.
C     .     IT IS USED AS A WORK ARRAY IN THE SORTING ALGORITHM.
C     ELEMENTS (IPERM(I),I) I=1, ... N  ARE NON-ZERO AT THE END OF
C     .     THE ALGORITHM UNLESS N ASSIGNMENTS HAVE NOT BEEN MADE.
C     .     IN WHICH CASE (IPERM(I),I) WILL BE ZERO FOR N-NUMNZ
C     .     ENTRIES.
C     CV(I) IS THE MOST RECENT ROW EXTENSION AT WHICH COLUMN I
C     .     WAS VISITED.
C     PREORD(I) IS THE ROW IN THE ORIGINAL MATRIX WHICH HAS THE
C     .     ITH SMALLEST NUMBER OF NON-ZEROS.
C     ARP(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I
C     .     WHICH HAVE NOT BEEN SCANNED WHEN LOOKING FOR A CHEAP
C     .     ASSIGNMENT.
C     OUT(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I
C     .     WHICH HAVE NOT BEEN SCANNED DURING ONE PASS THROUGH THE
C     .     MAIN LOOP.
C
C
C     INITIALIZATION OF ARRAYS.
C     .. Scalar Arguments ..
      INTEGER           LICN, N, NP1, NUMNZ
C     .. Array Arguments ..
      INTEGER           ARP(N), CV(NP1), ICN(LICN), IP(N), IPERM(N),
     *                  LENR(N), OUT(N), PR(N), PREORD(N)
C     .. Local Scalars ..
      INTEGER           I, II, IN1, IN2, IOUTK, IPTR, IROW, J, J1, JORD,
     *                  K, KK, NUM
C     .. Executable Statements ..
      DO 20 I = 1, N
         ARP(I) = LENR(I) - 1
         CV(I) = 0
         IPERM(I) = 0
   20 CONTINUE
      CV(NP1) = 0
      NUMNZ = 0
C
C     ROWS ORDERED IN ORDER OF INCREASING NUMBER OF NON-ZEROS,
C     USING  LIST SORT INVOLVING O(N) OPERATIONS.
      DO 40 I = 1, N
         IROW = LENR(I) + 1
         PR(I) = CV(IROW)
         CV(IROW) = I
   40 CONTINUE
      NUM = 1
      DO 100 I = 1, NP1
         IPTR = CV(I)
         DO 60 J = 1, N
            IF (IPTR.EQ.0) GO TO 80
            PREORD(NUM) = IPTR
            NUM = NUM + 1
            IPTR = PR(IPTR)
   60    CONTINUE
   80    CV(I) = 0
  100 CONTINUE
C
C     MAIN LOOP.
C     EACH PASS ROUND THIS LOOP EITHER RESULTS IN A NEW ASSIGNMENT
C     OR GIVES A ROW WITH NO ASSIGNMENT.
      DO 280 JORD = 1, N
         J = PREORD(JORD)
         PR(J) = -1
         DO 220 K = 1, JORD
C           LOOK FOR A CHEAP ASSIGNMENT
            IN1 = ARP(J)
            IF (IN1.LT.0) GO TO 140
            IN2 = IP(J) + LENR(J) - 1
            IN1 = IN2 - IN1
            DO 120 II = IN1, IN2
               I = ICN(II)
               IF (IPERM(I).EQ.0) GO TO 240
  120       CONTINUE
C           NO CHEAP ASSIGNMENT IN ROW.
            ARP(J) = -1
C           BEGIN LOOKING FOR ASSIGNMENT CHAIN STARTING WITH ROW J.
  140       OUT(J) = LENR(J) - 1
C           INNER LOOP.  EXTENDS CHAIN BY ONE OR BACKTRACKS.
            DO 200 KK = 1, JORD
               IN1 = OUT(J)
               IF (IN1.LT.0) GO TO 180
               IN2 = IP(J) + LENR(J) - 1
               IN1 = IN2 - IN1
C              FORWARD SCAN.
               DO 160 II = IN1, IN2
                  I = ICN(II)
                  IF (CV(I).EQ.JORD) GO TO 160
C                 COLUMN I HAS NOT YET BEEN ACCESSED DURING THIS PASS.
                  J1 = J
                  J = IPERM(I)
                  CV(I) = JORD
                  PR(J) = J1
                  OUT(J1) = IN2 - II - 1
                  GO TO 220
  160          CONTINUE
C
C              BACKTRACKING STEP.
  180          J = PR(J)
               IF (J.EQ.-1) GO TO 280
  200       CONTINUE
  220    CONTINUE
C
C        NEW ASSIGNMENT IS MADE.
  240    IPERM(I) = J
         ARP(J) = IN2 - II - 1
         NUMNZ = NUMNZ + 1
         DO 260 K = 1, JORD
            J = PR(J)
            IF (J.EQ.-1) GO TO 280
            II = IP(J) + LENR(J) - OUT(J) - 2
            I = ICN(II)
            IPERM(I) = J
  260    CONTINUE
  280 CONTINUE
C
C     IF MATRIX IS STRUCTURALLY SINGULAR, WE NOW COMPLETE THE
C     PERMUTATION IPERM.
      IF (NUMNZ.EQ.N) RETURN
      DO 300 I = 1, N
         ARP(I) = 0
  300 CONTINUE
      K = 0
      DO 340 I = 1, N
         IF (IPERM(I).NE.0) GO TO 320
         K = K + 1
         OUT(K) = I
         GO TO 340
  320    J = IPERM(I)
         ARP(J) = I
  340 CONTINUE
      K = 0
      DO 360 I = 1, N
         IF (ARP(I).NE.0) GO TO 360
         K = K + 1
         IOUTK = OUT(K)
         IPERM(IOUTK) = I
  360 CONTINUE
      RETURN
      END
      SUBROUTINE F01BRX(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MC21A
C
C     INTERFACE FOR F01BRW
C
C     .. Scalar Arguments ..
      INTEGER           LICN, N, NUMNZ
C     .. Array Arguments ..
      INTEGER           ICN(LICN), IP(N), IPERM(N), IW(N,5), LENR(N)
C     .. Local Scalars ..
      INTEGER           NP1
C     .. External Subroutines ..
      EXTERNAL          F01BRW
C     .. Executable Statements ..
      NP1 = N + 1
      CALL F01BRW(N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW(1,1),IW(1,2),IW(1,3)
     *            ,IW(1,4),IW(1,5),NP1)
      RETURN
      END
      SUBROUTINE F01BRY(N,ICN,A,LICN,LENR,IDISP,IP,IQ,LENOFF,IW,IW1,
     *                  ABORT,IFAIL)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MC23A
C
C     PERMUTES THE ROWS AND COLUMNS OF A SPARSE MATRIX SO THAT IT IS
C     IN BLOCK LOWER TRIANGULAR FORM
C
C     .. Scalar Arguments ..
      INTEGER           IFAIL, LICN, N
      LOGICAL           ABORT
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LICN)
      INTEGER           ICN(LICN), IDISP(10), IP(N), IQ(N), IW(N,5),
     *                  IW1(N,2), LENOFF(N), LENR(N)
C     .. Local Scalars ..
      INTEGER           I, I1, I2, IBEG, IBLOCK, IEND, II, ILEND, INEW,
     *                  IOLD, IROWB, IROWE, ISAVE, J, JJ, JNEW, JNPOS,
     *                  JOLD, K, LARGE, LENI, NERR, NUM, NUMNZ, NZ
C     .. Local Arrays ..
      CHARACTER*56      REC(3)
C     .. External Subroutines ..
      EXTERNAL          F01BRV, F01BRX, X04AAF, X04BAF
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN, MOD
C     .. Executable Statements ..
      ISAVE = IFAIL
      IFAIL = 0
C
C     SET UP POINTERS IW(.,1) TO THE BEGINNING OF THE ROWS AND SET
C     LENOFF EQUAL TO LENR.
      IW1(1,1) = 1
      LENOFF(1) = LENR(1)
C     INITIALIZE NUM AND LARGE TO PREVENT ASSIGNMENT OF UNSET
C     VARIABLES AT END OF ROUTINE IN THE EVENT OF A FAILURE.
      NUM = 0
      LARGE = 0
      IF (N.EQ.1) GO TO 40
      DO 20 I = 2, N
         LENOFF(I) = LENR(I)
         IW1(I,1) = IW1(I-1,1) + LENR(I-1)
   20 CONTINUE
C     IDISP(1) POINTS TO THE FIRST POSITION IN A/ICN AFTER THE
C     OFF-DIAGONAL BLOCKS AND UNTREATED ROWS.
   40 IDISP(1) = IW1(N,1) + LENR(N)
C
C     FIND ROW PERMUTATION IP TO MAKE DIAGONAL ZERO-FREE.
      CALL F01BRX(N,ICN,LICN,IW1,LENR,IP,NUMNZ,IW)
C
C     POSSIBLE ERROR RETURN FOR STRUCTURALLY SINGULAR MATRICES.
      IF (NUMNZ.NE.N .AND. ABORT) GO TO 340
C
C     IW1(.,2) AND LENR ARE PERMUTATIONS OF IW1(.,1) AND
C     LENR/LENOFF SUITABLE FOR ENTRY
C     TO F01BRV SINCE MATRIX WITH THESE ROW POINTER AND LENGTH
C     ARRAYS HAS MAXIMUM NUMBER OF NON-ZEROS ON THE DIAGONAL.
      DO 60 II = 1, N
         I = IP(II)
         IW1(II,2) = IW1(I,1)
         LENR(II) = LENOFF(I)
   60 CONTINUE
C
C     FIND SYMMETRIC PERMUTATION IQ TO BLOCK LOWER TRIANGULAR FORM.
      CALL F01BRV(N,ICN,LICN,IW1(1,2),LENR,IQ,IW(1,4),NUM,IW)
C
      IF (NUM.NE.1) GO TO 120
C
C     ACTION TAKEN IF MATRIX IS IRREDUCIBLE.
C     WHOLE MATRIX IS JUST MOVED TO THE END OF THE STORAGE.
      DO 80 I = 1, N
         LENR(I) = LENOFF(I)
         IP(I) = I
         IQ(I) = I
   80 CONTINUE
      LENOFF(1) = -1
C     IDISP(1) IS THE FIRST POSITION AFTER THE LAST ELEMENT IN THE
C     OFF-DIAGONAL BLOCKS AND UNTREATED ROWS.
      NZ = IDISP(1) - 1
      IDISP(1) = 1
C     IDISP(2) IS THE POSITION IN A/ICN OF THE FIRST ELEMENT IN THE
C     DIAGONAL BLOCKS.
      IDISP(2) = LICN - NZ + 1
      LARGE = N
      IF (NZ.EQ.LICN) GO TO 400
      DO 100 K = 1, NZ
         J = NZ - K + 1
         JJ = LICN - K + 1
         A(JJ) = A(J)
         ICN(JJ) = ICN(J)
  100 CONTINUE
      GO TO 400
C
C     DATA STRUCTURE REORDERED.
C
C     FORM COMPOSITE ROW PERMUTATION ... IP(I) = IP(IQ(I)).
  120 DO 140 II = 1, N
         I = IQ(II)
         IW(II,1) = IP(I)
  140 CONTINUE
      DO 160 I = 1, N
         IP(I) = IW(I,1)
  160 CONTINUE
C
C     RUN THROUGH BLOCKS IN REVERSE ORDER SEPARATING DIAGONAL
C     BLOCKS WHICH ARE MOVED TO THE END OF THE STORAGE.  ELEMENTS IN
C     OFF-DIAGONAL BLOCKS ARE LEFT IN PLACE UNLESS A COMPRESS IS
C     NECESSARY.
C
C     IBEG INDICATES THE LOWEST VALUE OF J FOR WHICH ICN(J) HAS
C     BEEN SET TO ZERO WHEN ELEMENT IN POSITION J WAS MOVED TO THE
C     DIAGONAL BLOCK PART OF STORAGE.
      IBEG = LICN + 1
C     IEND IS THE POSITION OF THE FIRST ELEMENT OF THOSE TREATED
C     ROWS WHICH ARE IN DIAGONAL BLOCKS.
      IEND = LICN + 1
C     LARGE IS THE DIMENSION OF THE LARGEST BLOCK ENCOUNTERED SO
C     FAR.
      LARGE = 0
C
C     NUM IS THE NUMBER OF DIAGONAL BLOCKS.
      DO 300 K = 1, NUM
         IBLOCK = NUM - K + 1
C        I1 IS FIRST ROW (IN PERMUTED FORM) OF BLOCK IBLOCK.
C        I2 IS LAST ROW (IN PERMUTED FORM) OF BLOCK IBLOCK.
         I1 = IW(IBLOCK,4)
         I2 = N
         IF (K.NE.1) I2 = IW(IBLOCK+1,4) - 1
         LARGE = MAX(LARGE,I2-I1+1)
C        GO THROUGH THE ROWS OF BLOCK IBLOCK IN THE REVERSE ORDER.
         DO 280 II = I1, I2
            INEW = I2 - II + I1
C           WE NOW DEAL WITH ROW INEW IN PERMUTED FORM (ROW IOLD IN
C           ORIGINAL MATRIX).
            IOLD = IP(INEW)
C           IF THERE IS SPACE TO MOVE UP DIAGONAL BLOCK PORTION
C           OF ROW GO TO ...
            IF (IEND-IDISP(1).GE.LENOFF(IOLD)) GO TO 220
C
C           IN-LINE COMPRESS.
C           MOVES SEPARATED OFF-DIAGONAL ELEMENTS AND UNTREATED ROWS TO
C           FRONT OF STORAGE.
            JNPOS = IBEG
            ILEND = IDISP(1) - 1
            IF (ILEND.LT.IBEG) GO TO 360
            DO 180 J = IBEG, ILEND
               IF (ICN(J).EQ.0) GO TO 180
               ICN(JNPOS) = ICN(J)
               A(JNPOS) = A(J)
               JNPOS = JNPOS + 1
  180       CONTINUE
            IDISP(1) = JNPOS
            IF (IEND-JNPOS.LT.LENOFF(IOLD)) GO TO 360
            IBEG = LICN + 1
C           RESET POINTERS TO THE BEGINNING OF THE ROWS.
            DO 200 I = 2, N
               IW1(I,1) = IW1(I-1,1) + LENOFF(I-1)
  200       CONTINUE
C
C           ROW IOLD IS NOW SPLIT INTO DIAG. AND OFF-DIAG. PARTS.
  220       IROWB = IW1(IOLD,1)
            LENI = 0
            IROWE = IROWB + LENOFF(IOLD) - 1
C           BACKWARD SCAN OF WHOLE OF ROW IOLD (IN ORIGINAL MATRIX).
            IF (IROWE.LT.IROWB) GO TO 260
            DO 240 JJ = IROWB, IROWE
               J = IROWE - JJ + IROWB
               JOLD = ICN(J)
C              IW(.,2) HOLDS THE INVERSE PERMUTATION TO IQ.
C              ..... IT WAS SET TO THIS IN F01BRV.
               JNEW = IW(JOLD,2)
C              IF (JNEW.LT.I1) THEN ....
C              ELEMENT IS IN OFF-DIAGONAL BLOCK AND SO IS LEFT IN SITU.
               IF (JNEW.LT.I1) GO TO 240
C              ELEMENT IS IN DIAGONAL BLOCK AND IS MOVED TO THE
C              END OF THE STORAGE.
               IEND = IEND - 1
               A(IEND) = A(J)
               ICN(IEND) = JNEW
               IBEG = MIN(IBEG,J)
               ICN(J) = 0
               LENI = LENI + 1
  240       CONTINUE
            LENOFF(IOLD) = LENOFF(IOLD) - LENI
  260       LENR(INEW) = LENI
  280    CONTINUE
         IP(I2) = -IP(I2)
  300 CONTINUE
C     RESETS IP(N) TO POSITIVE VALUE.
      IP(N) = -IP(N)
C     IDISP(2) IS POSITION OF FIRST ELEMENT IN DIAGONAL BLOCKS.
      IDISP(2) = IEND
C
C     THIS COMPRESS IS USED TO MOVE ALL OFF-DIAGONAL ELEMENTS TO
C     THE FRONT OF THE STORAGE.
      IF (IBEG.GT.LICN) GO TO 400
      JNPOS = IBEG
      ILEND = IDISP(1) - 1
      DO 320 J = IBEG, ILEND
         IF (ICN(J).EQ.0) GO TO 320
         ICN(JNPOS) = ICN(J)
         A(JNPOS) = A(J)
         JNPOS = JNPOS + 1
  320 CONTINUE
C     IDISP(1) IS FIRST POSITION AFTER LAST ELEMENT OF OFF-DIAGONAL
C     BLOCKS.
      IDISP(1) = JNPOS
      GO TO 400
C
C     ERROR RETURN
C     IFAIL = 1 - MATRIX IS STRUCTURALLY SINGULAR, RANK = NUMNZ
C     IFAIL = 7 - LICN NOT BIG ENOUGH, INCREASE BY N
C
  340 IFAIL = 1
      GO TO 380
  360 IFAIL = 7
  380 CONTINUE
C     ** CODE FOR OUTPUT OF ERROR MESSAGES *************************
      IF (MOD(ISAVE/10,10).EQ.0) GO TO 400
      CALL X04AAF(0,NERR)
      IF (IFAIL.EQ.1) THEN
         WRITE (REC,FMT=99999) NUMNZ
         CALL X04BAF(NERR,REC(1))
         CALL X04BAF(NERR,REC(2))
         CALL X04BAF(NERR,REC(3))
      END IF
      IF (IFAIL.EQ.7) THEN
         WRITE (REC,FMT=99998) N
         CALL X04BAF(NERR,REC(1))
         CALL X04BAF(NERR,REC(2))
      END IF
C     ** END OF CODE FOR OUTPUT OF ERROR MESSAGES ******************
  400 IDISP(8) = NUMNZ
      IDISP(9) = NUM
      IDISP(10) = LARGE
      RETURN
C
99999 FORMAT (/' MATRIX IS STRUCTURALLY SINGULAR - DECOMPOSITION ABORT',
     *  'ED',/'  RANK = ',I6)
99998 FORMAT (/' LICN NOT BIG ENOUGH FOR PERMUTATION - INCREASE BY',I6)
      END
      SUBROUTINE F01BRZ(NC,MAXA,A,INUM,JPTR,JNUM)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MC20A
C
C     SORTS THE NON-ZEROS OF A SPARSE MATRIX FROM ARBITRARY ORDER
C     TO COLUMN ORDER, UNORDERED WITHIN EACH COLUMN.
C
C     .. Scalar Arguments ..
      INTEGER           MAXA, NC
C     .. Array Arguments ..
      DOUBLE PRECISION  A(MAXA)
      INTEGER           INUM(MAXA), JNUM(MAXA), JPTR(NC)
C     .. Local Scalars ..
      DOUBLE PRECISION  ACE, ACEP
      INTEGER           I, ICE, ICEP, J, JA, JB, JCE, JCEP, JDISP, K,
     *                  KR, LOC, NULL
C     .. Executable Statements ..
      JDISP = 0
      NULL = -JDISP
C     CLEAR JPTR
      DO 20 J = 1, NC
         JPTR(J) = 0
   20 CONTINUE
C     COUNT THE NUMBER OF ELEMENTS IN EACH COLUMN.
      DO 40 K = 1, MAXA
         J = JNUM(K) + JDISP
         JPTR(J) = JPTR(J) + 1
   40 CONTINUE
C     SET THE JPTR ARRAY
      K = 1
      DO 60 J = 1, NC
         KR = K + JPTR(J)
         JPTR(J) = K
         K = KR
   60 CONTINUE
C
C     REORDER THE ELEMENTS INTO COLUMN ORDER.  THE ALGORITHM
C     IS AN IN-PLACE SORT AND IS OF ORDER MAXA.
      DO 100 I = 1, MAXA
C        ESTABLISH THE CURRENT ENTRY.
         JCE = JNUM(I) + JDISP
         IF (JCE.EQ.0) GO TO 100
         ACE = A(I)
         ICE = INUM(I)
C        CLEAR THE LOCATION VACATED.
         JNUM(I) = NULL
C        CHAIN FROM CURRENT ENTRY TO STORE ITEMS.
         DO 80 J = 1, MAXA
C           CURRENT ENTRY NOT IN CORRECT POSITION.  DETERMINE CORRECT
C           POSITION TO STORE ENTRY.
            LOC = JPTR(JCE)
            JPTR(JCE) = JPTR(JCE) + 1
C           SAVE CONTENTS OF THAT LOCATION.
            ACEP = A(LOC)
            ICEP = INUM(LOC)
            JCEP = JNUM(LOC)
C           STORE CURRENT ENTRY.
            A(LOC) = ACE
            INUM(LOC) = ICE
            JNUM(LOC) = NULL
C           CHECK IF NEXT CURRENT ENTRY NEEDS TO BE PROCESSED.
            IF (JCEP.EQ.NULL) GO TO 100
C           IT DOES.  COPY INTO CURRENT ENTRY.
            ACE = ACEP
            ICE = ICEP
            JCE = JCEP + JDISP
   80    CONTINUE
  100 CONTINUE
C
C     **      RESET JPTR VECTOR.
      JA = 1
      DO 120 J = 1, NC
         JB = JPTR(J)
         JPTR(J) = JA
         JA = JB
  120 CONTINUE
      RETURN
      END
      SUBROUTINE F06ECF( N, ALPHA, X, INCX, Y, INCY )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     .. Entry Points ..
      ENTRY      DAXPY ( N, ALPHA, X, INCX, Y, INCY )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, N
C     .. Array Arguments ..
      DOUBLE PRECISION   X( * ), Y( * )
C     ..
C
C  F06ECF performs the operation
C
C     y := alpha*x + y
C
C
C  Nag Fortran 77 version of the Blas routine DAXPY.
C  Nag Fortran 77 O( n ) basic linear algebra routine.
C
C  -- Written on 3-September-1982.
C     Sven Hammarling, Nag Central Office.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      INTEGER            I, IX, IY
C     ..
C     .. Executable Statements ..
      IF( N.GT.0 )THEN
         IF( ALPHA.NE.ZERO )THEN
            IF( ( INCX.EQ.INCY ).AND.( INCX.GT.0 ) )THEN
               DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
                  Y( IX ) = ALPHA*X( IX ) + Y( IX )
   10          CONTINUE
            ELSE
               IF( INCY.GE.0 )THEN
                  IY = 1
               ELSE
                  IY = 1 - ( N - 1 )*INCY
               END IF
               IF( INCX.GT.0 )THEN
                  DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX
                     Y( IY ) = ALPHA*X( IX ) + Y( IY )
                     IY      = IY            + INCY
   20             CONTINUE
               ELSE
                  IX = 1 - ( N - 1 )*INCX
                  DO 30, I = 1, N
                     Y( IY ) = ALPHA*X( IX ) + Y( IY )
                     IX      = IX            + INCX
                     IY      = IY            + INCY
   30             CONTINUE
               END IF
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of F06ECF. ( DAXPY )
C
      END
      SUBROUTINE F06EFF( N, X, INCX, Y, INCY )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     .. Entry Points ..
      ENTRY      DCOPY ( N, X, INCX, Y, INCY )
C     .. Scalar Arguments ..
      INTEGER            INCX, INCY, N
C     .. Array Arguments ..
      DOUBLE PRECISION   X( * ), Y( * )
C     ..
C
C  F06EFF performs the operation
C
C     y := x
C
C
C  Nag Fortran 77 version of the Blas routine DCOPY.
C  Nag Fortran 77 O( n ) basic linear algebra routine.
C
C  -- Written on 26-November-1982.
C     Sven Hammarling, Nag Central Office.
C
C
C     .. Local Scalars ..
      INTEGER            I, IX, IY
C     ..
C     .. Executable Statements ..
      IF( N.GT.0 )THEN
         IF( ( INCX.EQ.INCY ).AND.( INCY.GT.0 ) )THEN
            DO 10, IY = 1, 1 + ( N - 1 )*INCY, INCY
               Y( IY ) = X( IY )
   10       CONTINUE
         ELSE
            IF( INCX.GE.0 )THEN
               IX = 1
            ELSE
               IX = 1 - ( N - 1 )*INCX
            END IF
            IF( INCY.GT.0 )THEN
               DO 20, IY = 1, 1 + ( N - 1 )*INCY, INCY
                  Y( IY ) = X( IX )
                  IX      = IX      + INCX
   20          CONTINUE
            ELSE
               IY = 1 - ( N - 1 )*INCY
               DO 30, I = 1, N
                  Y( IY ) = X( IX )
                  IY      = IY      + INCY
                  IX      = IX      + INCX
   30          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of F06EFF. ( DCOPY )
C
      END
      SUBROUTINE F06ETF(NZ,A,X,INDX,Y)
C     MARK 14 RELEASE. NAG COPYRIGHT 1989.
C
C     PURPOSE
C
C         DAXPYI ADDS A REAL SCALAR MULTIPLE OF
C             A REAL SPARSE VECTOR  X
C             STORED IN COMPRESSED FORM  (X,INDX)
C         TO
C             A REAL VECTOR  Y  IN FULL STORAGE FORM.
C
C         ONLY THE ELEMENTS OF  Y  WHOSE INDICES ARE LISTED IN  INDX
C         ARE REFERENCED OR MODIFIED.  THE VALUES IN  INDX  MUST BE
C         DISTINCT TO ALLOW CONSISTENT VECTOR OR PARALLEL EXECUTION.
C
C         ALTHOUGH DISTINCT INDICES WILL ALLOW VECTOR OR PARALLEL
C         EXECUTION, MOST COMPILERS FOR HIGH-PERFORMANCE MACHINES WILL
C         BE UNABLE TO GENERATE BEST POSSIBLE CODE WITHOUT SOME
C         MODIFICATION, SUCH AS COMPILER DIRECTIVES, TO THIS CODE.
C
C     ARGUMENTS
C
C     INPUT ...
C
C         NZ      INTEGER     NUMBER OF ELEMENTS IN THE COMPRESSED FORM.
C         A       REAL        SCALAR MULTIPLIER OF  X.
C         X       REAL        ARRAY CONTAINING THE VALUES OF THE
C                             COMPRESSED FORM.
C         INDX    INTEGER     ARRAY CONTAINING THE INDICES OF THE
C                             COMPRESSED FORM.  IT IS ASSUMED THAT
C                             THE ELEMENTS IN  INDX  ARE DISTINCT.
C
C     UPDATED ...
C
C         Y       REAL        ARRAY, ON INPUT, WHICH CONTAINS THE
C                             VECTOR  Y  IN FULL STORAGE FORM.  ON
C                             OUTPUT ONLY THE ELEMENTS CORRESPONDING TO
C                             THE INDICES IN  INDX  HAVE BEEN MODIFIED.
C
C     SPARSE BASIC LINEAR ALGEBRA SUBPROGRAM
C
C     FORTRAN VERSION WRITTEN OCTOBER 1984
C     ROGER G GRIMES, BOEING COMPUTER SERVICES
C
C     .. Entry Points ..
      ENTRY             DAXPYI(NZ,A,X,INDX,Y)
C     .. Scalar Arguments ..
      DOUBLE PRECISION  A
      INTEGER           NZ
C     .. Array Arguments ..
      DOUBLE PRECISION  X(*), Y(*)
      INTEGER           INDX(*)
C     .. Local Scalars ..
      INTEGER           I
C     .. Executable Statements ..
      IF (NZ.LE.0) RETURN
C
      IF (A.EQ.0.0D0) RETURN
C
      DO 20 I = 1, NZ
         Y(INDX(I)) = Y(INDX(I)) + A*X(I)
   20 CONTINUE
C
      RETURN
      END
      SUBROUTINE F06FBF( N, CONST, X, INCX )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     .. Scalar Arguments ..
      DOUBLE PRECISION   CONST
      INTEGER            INCX, N
C     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
C     ..
C
C  F06FBF performs the operation
C
C     x = const*e,   e' = ( 1  1 ... 1 ).
C
C
C  Nag Fortran 77 O( n ) basic linear algebra routine.
C
C  -- Written on 22-September-1983.
C     Sven Hammarling, Nag Central Office.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      INTEGER            IX
C     ..
C     .. Executable Statements ..
      IF( N.GT.0 )THEN
         IF( CONST.NE.ZERO )THEN
            DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
               X( IX ) = CONST
   10       CONTINUE
         ELSE
            DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX
               X( IX ) = ZERO
   20       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of F06FBF. ( SLOAD )
C
      END
!interpolants
! E01AEF
! E01AEU
! E01AEV
! E01AEW
! E01AEX
! E01AEY
! E01AEZ

      SUBROUTINEM28BYS(N,NZ,A,LICN,IVECT,JVECT,ICN,IKEEP,IW,W,GROW,EPS,RMIN,ABORT,IDISP,IFAIL)
      DOUBLEPRECISIONEPS,RMIN
      INTEGERIFAIL,LICN,N,NZ
      LOGICALABORT,GROW
      DOUBLEPRECISIONA(LICN),W(N)
      INTEGERICN(LICN),IDISP(2),IKEEP(N,5),IVECT(NZ),IW(N,5),JVECT(NZ)
      CHARACTER*6SRNAME
      PARAMETER(SRNAME='M28BYS')
      DOUBLEPRECISIONWMAX
      INTEGERI1,IEND,IR,ISAVE,NERR
      CHARACTER*1P01REC(1)
      CHARACTER*65REC(2)
      INTEGERP01ABF
      EXTERNALP01ABF
      EXTERNALF01BRQ,M30BYS,X04AAF,X04BAF
      INTRINSICMOD
      ISAVE=IFAIL
      CALLX04AAF(0,NERR)
      IF(N.GT.0)GOTO20
      IFAIL=1
      GOTO120
20    IF(NZ.GT.0)GOTO40
      IFAIL=2
      GOTO120
40    IF(LICN.GE.NZ)GOTO60
      IFAIL=3
      GOTO120
60    CALLM28DYS(N,A,LICN,IVECT,JVECT,NZ,ICN,IKEEP,IKEEP(1,4),IKEEP(1,5),IKEEP(1,2),IKEEP(1,3),IW(1,3),IW,W(1),ABORT,IDISP,IFAIL)
      WMAX=W(1)
      IF(IFAIL.NE.0)GOTO120
      IFAIL=ISAVE
      CALLM30BYS(N,ICN,A,LICN,IKEEP,IKEEP(1,4),IDISP,IKEEP(1,2),IKEEP(1,3),W,IW,EPS,RMIN,IFAIL)
      IF(IFAIL.EQ.0)GOTO100
      IF(IFAIL.GT.0)GOTO80
      IR=-IFAIL
      IFAIL=6
      GOTO120
80    IR=IFAIL
      IFAIL=7
100   I1=IDISP(1)
      IEND=LICN-I1+1
      IF(GROW)CALLF01BRQ(N,ICN,A(I1),IEND,IKEEP,IKEEP(1,4),W)
      IF(GROW)W(1)=W(1)+WMAX
      IF(IFAIL.EQ.0)GOTO160
120   CONTINUE
      IF(MOD(ISAVE/10,10).EQ.0)GOTO140
      CALLX04AAF(0,NERR)
      GOTO(09999,09998,09997,09996,09995,09994,09993,09992),IFAIL
      GOTO09991
09999 CONTINUE
      WRITE(REC,FMT=99999)N
      GOTO09991
09998 CONTINUE
      WRITE(REC,FMT=99998)NZ
      GOTO09991
09997 CONTINUE
      WRITE(REC,FMT=99997)LICN,NZ
      GOTO09991
09996 CONTINUE
      GOTO09991
09995 CONTINUE
      GOTO09991
09994 CONTINUE
      WRITE(REC,FMT=99996)IR
      IW(1,1)=IR
      GOTO09991
09993 CONTINUE
      WRITE(REC,FMT=99995)IR
      GOTO09991
09992 CONTINUE
      WRITE(REC,99994)
09991 CONTINUE
      IF((IFAIL.GE.1.AND.IFAIL.LE.3).OR.(IFAIL.GE.6.AND.IFAIL.LE.8))THEN
      CALLX04BAF(NERR,REC(1))
      CALLX04BAF(NERR,REC(2))
      ENDIF
      IF(IFAIL.EQ.7)GOTO160
140   IFAIL=P01ABF(ISAVE,IFAIL,SRNAME,0,P01REC)
160   RETURN
99999 FORMAT(/' ON ENTRY N .LE. 0 , N =',I10)
99998 FORMAT(/' ON ENTRY NZ .LE. 0 , NZ =',I10)
99997 FORMAT(/' ON ENTRY LICN .LT. NZ , LICN = ',I9,'  NZ = ',I9)
99996 FORMAT(/' NUMERICAL SINGULARITY IN ROW ',I8,' - DECOMPOSITION A','BORTED')
99995 FORMAT(/' SUBTHRESHOLD PIVOT IN ROW ',I8,' - DECOMPOSITION COMP','LETED')
99994 FORMAT(/' DUPLICATE ELEMENTS FOUND ON INPUT - SEE ADVISORY MESS','AGES')
      END
      SUBROUTINEM30BYS(N,ICN,A,LICN,LENR,LENRL,IDISP,IP,IQ,W,IW,EPS,RMIN,IFAIL)
      DOUBLEPRECISIONEPS,RMIN
      INTEGERIFAIL,LICN,N
      DOUBLEPRECISIONA(LICN),W(N)
      INTEGERICN(LICN),IDISP(2),IP(N),IQ(N),IW(N,2),LENR(N),LENRL(N)
      DOUBLEPRECISIONAU,ONE,ROWMAX,ZERO
      INTEGERI,IFIN,ILEND,IPIVJ,ISING,ISTART,J,JAY,JAYJAY,JFIN,JJ,PIVPOS,KIW
      LOGICALSTAB
      DATAZERO/0.0D0/,ONE/1.0D0/
      STAB=EPS.LE.ONE
      RMIN=EPS
      ISING=0
      IFAIL=0
      IF(N.EQ.1)GOTO320
      KIW=0
      DO20I=1,N
      W(I)=ZERO
20    CONTINUE
      IW(1,1)=IDISP(1)
      DO40I=2,N
      IW(I,1)=IW(I-1,1)+LENR(I-1)
40    CONTINUE
      DO280I=1,N
      ISTART=IW(I,1)
      IFIN=ISTART+LENR(I)-1
      ILEND=ISTART+LENRL(I)-1
      IF(ISTART.GT.ILEND)GOTO140
      DO60JJ=ISTART,IFIN
      J=ICN(JJ)
      W(J)=A(JJ)
60    CONTINUE
      DO100JJ=ISTART,ILEND
      J=ICN(JJ)
      IPIVJ=IW(J,1)+LENRL(J)
      AU=-W(J)/A(IPIVJ)
      IF(W(J).EQ.ZERO)THEN
      KIW=KIW+1
      IW(min(KIW,N),2)=J
      ENDIF
      W(J)=AU
      IPIVJ=IPIVJ+1
      JFIN=IW(J,1)+LENR(J)-1
      IF(IPIVJ.GT.JFIN)GOTO100
      DO80JAYJAY=IPIVJ,JFIN
      JAY=ICN(JAYJAY)
      IF(W(JAY).EQ.ZERO)THEN
      KIW=KIW+1
      IW(min(KIW,N),2)=JAY
      ENDIF
      W(JAY)=W(JAY)+AU*A(JAYJAY)
80    CONTINUE
100   CONTINUE
      DO120JJ=ISTART,IFIN
      J=ICN(JJ)
      A(JJ)=W(J)
120   CONTINUE
      DOJAY=1,KIW
      J=IW(min(JAY,N),2)
      W(J)=ZERO
      ENDDO
      KIW=0
140   PIVPOS=ILEND+1
      IF(IQ(I).GT.0)GOTO240
      IF(ISING.EQ.0)ISING=I
      IF(PIVPOS.GT.IFIN)GOTO160
      IF(A(PIVPOS).NE.ZERO)GOTO300
160   IF(ISTART.GT.IFIN)GOTO200
      DO180JJ=ISTART,IFIN
      IF(ICN(JJ).LT.ISING)GOTO180
      IF(A(JJ).NE.ZERO)GOTO300
180   CONTINUE
200   IF(PIVPOS.LE.IFIN)A(PIVPOS)=ONE
      IF(IP(I).GT.0.AND.I.NE.N)GOTO280
      DO220J=ISING,I
      IF((LENR(J)-LENRL(J)).EQ.0)GOTO220
      JJ=IW(J,1)+LENRL(J)
      A(JJ)=ZERO
220   CONTINUE
      ISING=0
      GOTO280
240   IF(PIVPOS.GT.IFIN)GOTO300
      IF(A(PIVPOS).EQ.ZERO)GOTO300
      IF(.NOT.STAB)GOTO280
      ROWMAX=ZERO
      DO260JJ=PIVPOS,IFIN
      ROWMAX=DMAX1(ROWMAX,DABS(A(JJ)))
260   CONTINUE
      IF(DABS(A(PIVPOS))/ROWMAX.GE.RMIN)GOTO280
      IFAIL=I
      RMIN=DABS(A(PIVPOS))/ROWMAX
280   CONTINUE
      GOTO320
300   IFAIL=-I
320   RETURN
      END
      SUBROUTINEM28DYS(N,A,LICN,IVECT,JVECT,NZ,ICN,LENR,LENRL,LENOFF,IP,IQ,IW1,IW,W1,ABORT,IDISP,IFAIL)
      implicitnone
      DOUBLEPRECISIONW1
      INTEGERIFAIL,LICN,N,NZ
      LOGICALABORT
      DOUBLEPRECISIONA(LICN)
      INTEGERICN(LICN),IDISP(2),IP(N),IQ(N),IVECT(NZ),IW1(N,3),IW(N,2),JVECT(NZ),LENOFF(N),LENR(N),LENRL(N)
      DOUBLEPRECISIONAA,ZERO
      INTEGERI,IBLOCK,IDISP2,IDUMMY,II,INEW,IOLD,ISAVE,J1,J2,JCOMP,JDUMMY,JJ,JNEW,JOLD,MIDPT,NADV,NERR
      LOGICALBLOCKL
      DATAZERO/0.0D0/
      ISAVE=IFAIL
      IFAIL=0
      CALLX04AAF(0,NERR)
      CALLX04ABF(0,NADV)
      BLOCKL=LENOFF(1).GE.0
      IBLOCK=1
      IW(1,1)=1
      IW(1,2)=IDISP(1)
      DO20I=1,N
      IW1(I,3)=IBLOCK
      IF(IP(I).LT.0)IBLOCK=IBLOCK+1
      II=IABS(IP(I))
      IW1(II,1)=I
      JJ=IQ(I)
      JJ=IABS(JJ)
      IW1(JJ,2)=I
      IF(I.EQ.1)GOTO20
      IF(BLOCKL)IW(I,1)=IW(I-1,1)+LENOFF(I-1)
      IW(I,2)=IW(I-1,2)+LENR(I-1)
20    CONTINUE
      IDISP2=IDISP(2)
      DO340I=1,NZ
      IF(I.GT.IDISP2)GOTO40
      IF(ICN(I).LT.0)GOTO340
40    IOLD=IVECT(I)
      JOLD=JVECT(I)
      AA=A(I)
      DO280IDUMMY=1,NZ
      IF(IOLD.LE.N.AND.IOLD.GT.0.AND.JOLD.LE.N.AND.JOLD.GT.0)GOTO60
      IFAIL=4
      IF(MOD(ISAVE/10,10).NE.0)WRITE(NERR,99999)I,A(I),IOLD,JOLD
      GOTO360
60    INEW=IW1(IOLD,1)
      JNEW=IW1(JOLD,2)
      IF(IW1(INEW,3)-IW1(JNEW,3))80,120,100
80    IFAIL=5
      IF(MOD(ISAVE/10,10).NE.0)WRITE(NERR,99998)IOLD,JOLD
      GOTO360
100   J1=IW(INEW,1)
      J2=J1+LENOFF(INEW)-1
      GOTO220
120   J1=IW(INEW,2)
      IF(INEW.GT.JNEW)GOTO140
      J2=J1+LENR(INEW)-1
      J1=J1+LENRL(INEW)
      GOTO220
140   J2=J1+LENRL(INEW)
      DO200JDUMMY=1,N
      MIDPT=(J1+J2)/2
      JCOMP=IABS(ICN(MIDPT))
      IF(JNEW-JCOMP)160,260,180
160   J2=MIDPT
      GOTO200
180   J1=MIDPT
200   CONTINUE
      IFAIL=5
      IF(MOD(ISAVE/10,10).NE.0)WRITE(NERR,99997)IOLD,JOLD
      GOTO360
220   DO240MIDPT=J1,J2
      IF(IABS(ICN(MIDPT)).EQ.JNEW)GOTO260
240   CONTINUE
      IFAIL=5
      IF(MOD(ISAVE/10,10).NE.0)WRITE(NERR,99997)IOLD,JOLD
      GOTO360
260   IF(ICN(MIDPT).LT.0)GOTO320
      IF(MIDPT.GT.NZ.OR.MIDPT.LE.I)GOTO300
      W1=A(MIDPT)
      A(MIDPT)=AA
      AA=W1
      IOLD=IVECT(MIDPT)
      JOLD=JVECT(MIDPT)
      ICN(MIDPT)=-ICN(MIDPT)
280   CONTINUE
300   A(MIDPT)=AA
      ICN(MIDPT)=-ICN(MIDPT)
      GOTO340
320   A(MIDPT)=A(MIDPT)+AA
      IF(MOD(ISAVE/100,100).NE.0)WRITE(NADV,99996)IOLD,JOLD,AA
      IF(ABORT)IFAIL=8
340   CONTINUE
360   W1=ZERO
      DO400I=1,IDISP2
      IF(ICN(I).LT.0)GOTO380
      A(I)=ZERO
      GOTO400
380   ICN(I)=-ICN(I)
      W1=DMAX1(W1,DABS(A(I)))
400   CONTINUE
      RETURN
99999 FORMAT(49H0ON ENTRY IRN(I) OR ICN(I) IS OUT OF RANGE - I = ,I8/9H  A(I) = ,1PD14.6,11H  IRN(I) = ,I8,11H  ICN(I) = ,I8)
99998 FORMAT(19H0NON-ZERO ELEMENT (,I6,1H,,I6,13H) IN ZERO OFF,15H-DIAGONAL BLOCK)
99997 FORMAT(19H0NON-ZERO ELEMENT (,I6,1H,,I6,13H) WAS NOT IN ,11HL/U PATTERN)
99996 FORMAT(45H0M28DYS FOUND DUPLICATE ELEMENT WITH INDICES ,I6,2H, ,I6/10H  VALUE = ,1PD14.6)
      END
      SUBROUTINEM28CYN(N,A,LICN,ICN,IKEEP,RHS,W,IW,MTYPE,IDISP,RESID,Ifail)
      DOUBLEPRECISIONRESID
      INTEGERLICN,MTYPE,N
      DOUBLEPRECISIONA(LICN),RHS(N),W(N)
      INTEGERICN(LICN),IDISP(2),IKEEP(N,5)
      CALLM30CYN(N,ICN,A,LICN,IKEEP,IKEEP(1,4),IKEEP(1,5),IDISP,IKEEP(1,2),IKEEP(1,3),RHS,W,MTYPE,RESID,Ifail)
      RETURN
      END
      SUBROUTINEM30CYN(N,ICN,A,LICN,LENR,LENRL,LENOFF,IDISP,IP,IQ,X,W,MTYPE,RESID,Ifail)
      DOUBLEPRECISIONRESID
      INTEGERLICN,MTYPE,N
      DOUBLEPRECISIONA(LICN),W(N),X(N)
      INTEGERICN(LICN),IDISP(2),IP(N),IQ(N),LENOFF(N),LENR(N),LENRL(N)
      DOUBLEPRECISIONWI,WII,ZERO
      INTEGERI,IB,IBACK,IBLEND,IBLOCK,IEND,IFIRST,II,III,ILAST,J1,J2,J3,J,JJ,JPIV,JPIVP1,K,LJ1,LJ2,LT,LTEND,NUMBLK
      LOGICALNEG,NOBLOC
      DATAZERO/0.0D0/
      Ifail=0
      RESID=ZERO
      NOBLOC=LENOFF(1).LT.0
      IF(MTYPE.NE.1)GOTO280
      NEG=.FALSE.
      IP(N)=-IP(N)
      DO20II=1,N
      I=IP(II)
      I=IABS(I)
      if(I.LE.0)write(*,*)' warning 1 m28cyn.trf: I=',I
      W(II)=X(max(I,1))
20    CONTINUE
      LT=1
      IFIRST=1
      IBLOCK=IDISP(1)
      DO240I=1,N
      WI=W(I)
      If(.NOT.NOBLOC.AND.LENOFF(I).NE.0)Then
      LTEND=LT+LENOFF(I)-1
      DO40JJ=LT,LTEND
      J=ICN(JJ)
      If(abs(A(JJ)).LT.1.D0)Then
      WI=WI-A(JJ)*W(J)
      elseIf(abs(W(J)).LT.1.D+300/abs(A(JJ)))Then
      WI=WI-A(JJ)*W(J)
      else
      Ifail=13
      Return
      endif
40    CONTINUE
      LT=LTEND+1
      Endif
      IF(IP(I).LT.0)NEG=.TRUE.
      IF(LENRL(I).NE.0)Then
      IEND=IBLOCK+LENRL(I)-1
      DO80JJ=IBLOCK,IEND
      J=ICN(JJ)
      If(abs(A(JJ)).LT.1.D0)Then
      WI=WI+A(JJ)*W(J)
      elseIf(abs(W(J)).LT.1.D+300/abs(A(JJ)))Then
      WI=WI+A(JJ)*W(J)
      else
      Ifail=13
      Return
      endif
80    CONTINUE
      Endif
      IBLOCK=IBLOCK+LENR(I)
      W(I)=WI
      IF(.NOT.NEG)GOTO240
      J1=IBLOCK
      IB=I
      IF(IQ(I).GT.0)GOTO140
      DO120III=IFIRST,I
      IB=I-III+IFIRST
      IF(IQ(IB).GT.0)GOTO140
      J1=J1-LENR(IB)
      RESID=DMAX1(RESID,DABS(W(IB)))
      W(IB)=ZERO
120   CONTINUE
      GOTO220
140   DO200II=IB,IFIRST,-1
      J2=J1-1
      J1=J1-LENR(II)
      JPIV=J1+LENRL(II)
      JPIVP1=JPIV+1
      If(J2.GE.JPIVP1)Then
      WII=W(II)
      DO160JJ=JPIVP1,J2
      J=ICN(JJ)
      WII=WII-A(JJ)*W(J)
160   CONTINUE
      W(II)=WII
      Endif
      If(1.D+135.LT.abs(A(JPIV)))Then
      W(II)=W(II)/A(JPIV)
      elseIf(abs(W(II)).LT.1.D+135*abs(A(JPIV)))Then
      W(II)=W(II)/A(JPIV)
      else
      Ifail=13
      Return
      endif
200   CONTINUE
220   IFIRST=I+1
      NEG=.FALSE.
240   CONTINUE
      DO260II=1,N
      I=IQ(II)
      I=IABS(I)
      if(I.LE.0)write(*,*)' warning 2 m28cyn.trf: I=',I
      X(max(I,1))=W(II)
260   CONTINUE
      IP(N)=-IP(N)
      GOTO640
280   DO300II=1,N
      I=IQ(II)
      I=IABS(I)
      W(II)=X(I)
300   CONTINUE
      LJ1=IDISP(1)
      IBLOCK=IDISP(2)+1
      ILAST=N
      IBLEND=IBLOCK
      DO580NUMBLK=1,N
      IF(ILAST.EQ.0)GOTO600
      IBLOCK=IBLOCK-LENR(ILAST)
      DO320K=1,N
      II=ILAST-K
      IF(II.EQ.0)GOTO340
      IF(IP(II).LT.0)GOTO340
      IBLOCK=IBLOCK-LENR(II)
320   CONTINUE
340   IFIRST=II+1
      J1=IBLOCK
      DO420I=IFIRST,ILAST
      IF(W(I).EQ.ZERO)GOTO400
      IF(IQ(I).LT.0)GOTO440
      J2=J1+LENRL(I)
      WI=W(I)/A(J2)
      IF(LENR(I)-LENRL(I).EQ.1)GOTO380
      J2=J2+1
      J3=J1+LENR(I)-1
      DO360JJ=J2,J3
      J=ICN(JJ)
      W(J)=W(J)-A(JJ)*WI
360   CONTINUE
380   W(I)=WI
400   J1=J1+LENR(I)
420   CONTINUE
      GOTO480
440   DO460II=I,ILAST
      RESID=DMAX1(RESID,DABS(W(II)))
      W(II)=ZERO
460   CONTINUE
480   J1=IBLEND
      DO560IBACK=IFIRST,ILAST
      I=ILAST-IBACK+IFIRST
      J1=J1-LENR(I)
      IF(LENRL(I).EQ.0)GOTO520
      J2=J1+LENRL(I)-1
      DO500JJ=J1,J2
      J=ICN(JJ)
      W(J)=W(J)+A(JJ)*W(I)
500   CONTINUE
520   IF(NOBLOC)GOTO560
      IF(LENOFF(I).EQ.0)GOTO560
      LJ2=LJ1-1
      LJ1=LJ1-LENOFF(I)
      DO540JJ=LJ1,LJ2
      J=ICN(JJ)
      W(J)=W(J)-A(JJ)*W(I)
540   CONTINUE
560   CONTINUE
      IBLEND=J1
      ILAST=IFIRST-1
580   CONTINUE
600   DO620II=1,N
      I=IP(II)
      I=IABS(I)
      X(I)=W(II)
620   CONTINUE
640   RETURN
      END
      SUBROUTINEM28CYS(N,A,LICN,ICN,IKEEP,RHS,W,MTYPE,IDISP,RESID)
      DOUBLEPRECISIONRESID
      INTEGERLICN,MTYPE,N
      DOUBLEPRECISIONA(LICN),RHS(N),W(N)
      INTEGERICN(LICN),IDISP(2),IKEEP(N,5)
      CALLM30CYS(N,ICN,A,LICN,IKEEP,IKEEP(1,4),IKEEP(1,5),IDISP,IKEEP(1,2),IKEEP(1,3),RHS,W,MTYPE,RESID)
      RETURN
      END
      SUBROUTINEM30CYS(N,ICN,A,LICN,LENR,LENRL,LENOFF,IDISP,IP,IQ,X,W,MTYPE,RESID)
      DOUBLEPRECISIONRESID
      INTEGERLICN,MTYPE,N
      DOUBLEPRECISIONA(LICN),W(N),X(N)
      INTEGERICN(LICN),IDISP(2),IP(N),IQ(N),LENOFF(N),LENR(N),LENRL(N)
      DOUBLEPRECISIONWI,WII,ZERO
      INTEGERI,IB,IBACK,IBLEND,IBLOCK,IEND,IFIRST,II,III,ILAST,J1,J2,J3,J,JJ,JPIV,JPIVP1,K,LJ1,LJ2,LT,LTEND,NUMBLK
      LOGICALNEG,NOBLOC
      DATAZERO/0.0D0/
      RESID=ZERO
      NOBLOC=LENOFF(1).LT.0
      IF(MTYPE.NE.1)GOTO280
      NEG=.FALSE.
      IP(N)=-IP(N)
      DO20II=1,N
      I=IP(II)
      I=IABS(I)
      W(II)=X(I)
20    CONTINUE
      LT=1
      IFIRST=1
      IBLOCK=IDISP(1)
      DO240I=1,N
      WI=W(I)
      IF(NOBLOC)GOTO60
      IF(LENOFF(I).EQ.0)GOTO60
      LTEND=LT+LENOFF(I)-1
      DO40JJ=LT,LTEND
      J=ICN(JJ)
      WI=WI-A(JJ)*W(J)
40    CONTINUE
      LT=LTEND+1
60    IF(IP(I).LT.0)NEG=.TRUE.
      IF(LENRL(I).EQ.0)GOTO100
      IEND=IBLOCK+LENRL(I)-1
      DO80JJ=IBLOCK,IEND
      J=ICN(JJ)
      WI=WI+A(JJ)*W(J)
80    CONTINUE
100   IBLOCK=IBLOCK+LENR(I)
      W(I)=WI
      IF(.NOT.NEG)GOTO240
      J1=IBLOCK
      IB=I
      IF(IQ(I).GT.0)GOTO140
      DO120III=IFIRST,I
      IB=I-III+IFIRST
      IF(IQ(IB).GT.0)GOTO140
      J1=J1-LENR(IB)
      RESID=DMAX1(RESID,DABS(W(IB)))
      W(IB)=ZERO
120   CONTINUE
      GOTO220
140   DO200III=IFIRST,IB
      II=IB-III+IFIRST
      J2=J1-1
      J1=J1-LENR(II)
      JPIV=J1+LENRL(II)
      JPIVP1=JPIV+1
      IF(J2.LT.JPIVP1)GOTO180
      WII=W(II)
      DO160JJ=JPIVP1,J2
      J=ICN(JJ)
      if(J.GT.N)write(*,*)' J = ICN(JJ), JJ ',J,JJ
      WII=WII-A(JJ)*W(J)
160   CONTINUE
      W(II)=WII
180   W(II)=W(II)/A(JPIV)
200   CONTINUE
220   IFIRST=I+1
      NEG=.FALSE.
240   CONTINUE
      DO260II=1,N
      I=IQ(II)
      I=IABS(I)
      X(I)=W(II)
260   CONTINUE
      IP(N)=-IP(N)
      GOTO640
280   DO300II=1,N
      I=IQ(II)
      I=IABS(I)
      W(II)=X(I)
300   CONTINUE
      LJ1=IDISP(1)
      IBLOCK=IDISP(2)+1
      ILAST=N
      IBLEND=IBLOCK
      DO580NUMBLK=1,N
      IF(ILAST.EQ.0)GOTO600
      IBLOCK=IBLOCK-LENR(ILAST)
      DO320K=1,N
      II=ILAST-K
      IF(II.EQ.0)GOTO340
      IF(IP(II).LT.0)GOTO340
      IBLOCK=IBLOCK-LENR(II)
320   CONTINUE
340   IFIRST=II+1
      J1=IBLOCK
      DO420I=IFIRST,ILAST
      IF(W(I).EQ.ZERO)GOTO400
      IF(IQ(I).LT.0)GOTO440
      J2=J1+LENRL(I)
      WI=W(I)/A(J2)
      IF(LENR(I)-LENRL(I).EQ.1)GOTO380
      J2=J2+1
      J3=J1+LENR(I)-1
      DO360JJ=J2,J3
      J=ICN(JJ)
      W(J)=W(J)-A(JJ)*WI
360   CONTINUE
380   W(I)=WI
400   J1=J1+LENR(I)
420   CONTINUE
      GOTO480
440   DO460II=I,ILAST
      RESID=DMAX1(RESID,DABS(W(II)))
      W(II)=ZERO
460   CONTINUE
480   J1=IBLEND
      DO560IBACK=IFIRST,ILAST
      I=ILAST-IBACK+IFIRST
      J1=J1-LENR(I)
      IF(LENRL(I).EQ.0)GOTO520
      J2=J1+LENRL(I)-1
      DO500JJ=J1,J2
      J=ICN(JJ)
      W(J)=W(J)+A(JJ)*W(I)
500   CONTINUE
520   IF(NOBLOC)GOTO560
      IF(LENOFF(I).EQ.0)GOTO560
      LJ2=LJ1-1
      LJ1=LJ1-LENOFF(I)
      DO540JJ=LJ1,LJ2
      J=ICN(JJ)
      W(J)=W(J)-A(JJ)*W(I)
540   CONTINUE
560   CONTINUE
      IBLEND=J1
      ILAST=IFIRST-1
580   CONTINUE
600   DO620II=1,N
      I=IP(II)
      I=IABS(I)
      X(I)=W(II)
620   CONTINUE
640   RETURN
      END
      SUBROUTINE M28Y12(N, NZ, A, LICN, IRN, LIRN, ICN, U, IKEEP,IW, W,
     * LBLOCK, GROW, ABORT, IDISP, IFAIL, THR)
C     DERIVED FROM HARWELL LIBRARY ROUTINE MA28A
C     THROUGH F01BRF MARK 7 RELEASE. NAG 1978
C     AND Y12M -- ZLATEV & 0STERBY
C
C     THE PARAMETERS ARE AS FOLLOWS.....
C     N     INTEGER  ORDER OF MATRIX  NOT ALTERED BY SUBROUTINE.
C     NZ    INTEGER  NUMBER OF NON-ZEROS IN INPUT MATRIX  NOT
C     .     ALTERED BY SUBROUTINE.
C     A     REAL ARRAY  LENGTH LICN.  HOLDS NON-ZEROS OF
C     .     MATRIX ON ENTRY AND NON-ZEROS OF FACTORS ON EXIT.
C     .     REORDERED BY F01BRZ AND F01BRY AND ALTERED BY M30Y12.
C     LICN  INTEGER  LENGTH OF ARRAYS A AND ICN.  NOT ALTERED BY
C     .     SUBROUTINE.
C     IRN   INTEGER ARRAY  LENGTH LIRN.  HOLDS ROW INDICES ON INPUT
C     .     AND USED AS WORKSPACE BY M30Y12 TO HOLD COLUMN
C     .     ORIENTATION OF MATRIX.
C     LIRN  INTEGER  LENGTH OF ARRAY IRN.
C     ICN   INTEGER ARRAY  LENGTH LICN.  HOLDS COLUMN INDICES ON
C     .     ENTRY AND COLUMN INDICES OF DECOMPOSED MATRIX ON EXIT.
C     .     REORDERED BY F01BRZ AND F01BRY AND ALTERED BY M30Y12.
C     U     REAL VARIABLE  SET BY USER TO CONTROL BIAS TOWARDS
C     .     NUMERIC OR SPARSITY PIVOTING.  U=1.0 GIVES PARTIAL
C     .     PIVOTING WHILE U=0. DOES NOT CHECK MULTIPLIERS AT ALL.
C     .     VALUES OF U GREATER THAN ONE ARE TREATED AS ONE WHILE
C     .     NEGATIVE VALUES ARE TREATED AS ZERO.  NOT ALTERED BY
C     .     SUBROUTINE.
C     IKEEP  INTEGER ARRAY  LENGTH 5*N  USED AS WORKSPACE BY M28Y12
C     .     (SEE LATER COMMENTS).  IT IS NOT REQUIRED TO BE SET ON
C     .     ENTRY AND, ON EXIT, IT CONTAINS INFORMATION ABOUT THE
C     .     DECOMPOSITION.  IT SHOULD BE PRESERVED BETWEEN THIS CALL
C     .     AND SUBSEQUENT CALLS TO M28BSF OR F04AXF.
C     IKEEP(I,1),I=1,N  HOLDS THE TOTAL LENGTH OF THE PART OF ROW I
C     .     IN THE DIAGONAL BLOCK.
C     ROW IKEEP(I,2),I=1,N  OF THE INPUT MATRIX IS THE ITH ROW IN
C     .     PIVOT ORDER.
C     COLUMN IKEEP(I,3),I=1,N  OF THE INPUT MATRIX IS THE ITH
C     .     COLUMN IN PIVOT ORDER.
C     IKEEP(I,4),I=1,N  HOLDS THE LENGTH OF THE PART OF ROW I IN
C     .     THE L PART OF THE L/U DECOMPOSITION.
C     IKEEP(I,5),I=1,N  HOLDS THE LENGTH OF THE PART OF ROW I IN
C     .     THE OFF-DIAGONAL BLOCKS.  IF THERE IS ONLY ONE DIAGONAL
C     .     BLOCK, IKEEP(1,5) WILL BE SET TO -1.
C     IW    INTEGER ARRAY LENGTH 8*N.
C     .     USED AS WORKSPACE.
C     W     REAL ARRAY  LENGTH N.  USED BY F01BRQ BOTH AS WORKSPACE
C     .     AND TO RETURN GROWTH ESTIMATE IN W(1).  THE USE OF THIS
C     .     ARRAY BY M28Y12 IS THUS OPTIONAL DEPENDING ON THE VALUE
C     .     OF PARAMETER GROW.
C     LBLOCK  LOGICAL IF TRUE, F01BRY IS USED TO FIRST PERMUTE
C     .     THE MATRIX TO BLOCK LOWER TRIANGULAR FORM.
C     GROW  LOGICAL IF TRUE, THEN AN ESTIMATE OF THE INCREASE
C     .     IN SIZE OF MATRIX ELEMENTS DURING L/U DECOMPOSITION IS
C     .     GIVEN BY F01BRQ IN W(1).
C     ABORT  LOGICAL ARRAY LENGTH 4.
C     IF ABORT(1)=TRUE, THE ROUTINE WILL EXIT IMMEDIATELY
C     .     ON DETECTING STRUCTURAL SINGULARITY.
C     IF ABORT(2)=TRUE, THE ROUTINE WILL EXIT IMMEDIATELY
C     .     ON DETECTING NUMERICAL SINGULARITY.
C     IF ABORT(3)=TRUE, THE ROUTINE WILL EXIT IMMEDIATELY WHEN THE
C     .     AVAILABLE SPACE IN A/ICN IS FILLED UP BY THE PREVIOUSLY
C     .     DECOMPOSED ACTIVE, AND UNDECOMPOSED PARTS OF THE MATRIX.
C     IF ABORT(4)=TRUE, THE ROUTINE WILL EXIT IMMEDIATELY
C     .     ON DETECTING DUPLICATE ELEMENTS IN THE INPUT MATRIX.
C     IDISP  INTEGER ARRAY LENGTH 11. USED TO COMMUNICATE
C     .     INFORMATION ABOUT THE DECOMPOSITION TO THE USER AND
C     .     ALSO BETWEEN THIS CALL TO M28Y12 AND SUBSEQUENT CALLS
C     .     TO M28BSF AND F04AXF.
C     ON EXIT -
C     IDISP(1) AND IDISP(2) INDICATE THE POSITION IN ARRAYS A AND
C     .     ICN OF THE FIRST AND LAST ELEMENTS IN THE L/U
C     .     DECOMPOSITION OF THE DIAGONAL BLOCKS RESPECTIVELY.
C     IDISP(3)= IRNCP  THE NUMBER OF COMPRESSES ON ARRAY IRN.
C     IDISP(4)= ICNCP  THE NUMBER OF COMPRESSES ON ARRAYS ICN/A.
C     IDISP(5)= IRANK  ESTIMATED RANK OF THE MATRIX.
C     IDISP(6)= MINIRN MINIMUM LENGTH OF ARRAY IRN FOR SUCCESS ON
C     .     FUTURE RUNS.
C     IDISP(7)= MINICN MINIMUM LENGTH OF ARRAYS ICN/A FOR SUCCESS
C     .     ON FUTURE RUNS.
C     IDISP(8)= NUMNZ  STRUCTURAL RANK OF MATRIX.
C     IDISP(9)= NUM    NUMBER OF DIAGONAL BLOCKS.
C     IDISP(10)=LARGE  SIZE OF LARGEST DIAGONAL BLOCK.
C     IDISP(11)=Number of singular row.
C     IFAIL  INTEGER VARIABLE  USED AS ERROR FLAG BY ROUTINE.
C     THR    REAL VARIABLE  SET BY USER AS ZLATEV THRESHOLD
C
C     INTERNAL VARIABLES AND WORKSPACE USED IN  M28Y12 ARE DEFINED
C     WITHIN THE SUBROUTINE IMMEDIATELY PRIOR TO THEIR FIRST USE.
C     .. SCALAR ARGUMENTS ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='M28Y12')
      DOUBLE PRECISION U, THR
      INTEGER IFAIL, LICN, LIRN, N, NZ
      LOGICAL GROW, LBLOCK
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION A(LICN), W(N)
      INTEGER ICN(LICN), IDISP(11), IKEEP(N,5), IRN(LIRN), IW(N,8)
      LOGICAL ABORT(4)
C     ..
C     .. LOCAL SCALARS ..
C$P 1
      DOUBLE PRECISION THEMAX, UPRIV, ZERO
      INTEGER I1, I, IEND, II, IPRIV4, ISAVE, J1, J2, J, JAY, JJ,KNUM,
     * LENGTH, MOVE, NADV, NERR, NEWJ1, NEWPOS
C     .. Local Arrays ..
      CHARACTER*1       P01REC(1)
      CHARACTER*65      REC(3)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          F01BRQ, F01BRR, M30Y12, F01BRY, F01BRZ, X04AAF,
     *                  X04ABF, X04BAF
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MOD
C     .. Data statements ..
      DATA ZERO /0.0D0/
      ISAVE = IFAIL
      IFAIL = 0
C     NERR IS THE UNIT NUMBER FOR ERROR MESSAGES
C     NADV IS THE UNIT NUMBER FOR DUPLICATE ELEMENT WARNING MESSAGES
      CALL X04AAF(0, NERR)
      CALL X04ABF(0, NADV)
C     UPRIV PRIVATE COPY OF U IS USED IN CASE IT IS OUTSIDE
C     RANGE  ZERO TO ONE  AND  IS THUS ALTERED BY M30Y12.
      UPRIV = U
C     SIMPLE DATA CHECK ON INPUT VARIABLES AND ARRAY DIMENSIONS.
      IF (N.GT.0) GO TO 20
      IFAIL = 8
      GO TO 320
   20 IF (NZ.GT.0) GO TO 40
      IFAIL = 9
      GO TO 320
   40 IF (LICN.GE.NZ) GO TO 60
      IFAIL = 10
      GO TO 320
   60 IF (LIRN.GE.NZ) GO TO 80
      IFAIL = 11
      GO TO 320
C
C     DATA CHECK TO SEE IF ALL INDICES LIE BETWEEN 1 AND N.
   80 DO 100 I=1,NZ
         IF (IRN(I).GT.0 .AND. IRN(I).LE.N .AND. ICN(I).GT.0 .AND.ICN(I)
     *   .LE.N) GO TO 100
C     ** CODE FOR OUTPUT OF ERROR MESSAGE **************************
         IF (MOD(ISAVE/10,10).NE.0) THEN
            WRITE (REC,FMT=99999) I, A(I), IRN(I), ICN(I)
            CALL X04BAF(NERR,REC(1))
            CALL X04BAF(NERR,REC(2))
            CALL X04BAF(NERR,REC(3))
         END IF
C     ** END OF CODE FOR OUTPUT OF ERROR MESSAGE *******************
         IFAIL = 12
  100 CONTINUE
      IF (IFAIL.GT.0) GO TO 340
C
C     SORT ELEMENTS INTO ROW ORDER.
C
      CALL F01BRZ(N, NZ, A, ICN, IW, IRN)
      IPRIV4 = IW(1,1)
C     PART OF IKEEP IS USED HERE AS A WORK-ARRAY.  IKEEP(I,2) IS
C     THE LAST ROW TO HAVE A NON-ZERO IN COLUMN I.  IKEEP(I,3)
C     IS THE OFF-SET OF COLUMN I FROM THE START OF THE ROW.
      DO 120 I=1,N
         IKEEP(I,2) = 0
         IKEEP(I,1) = 0
  120 CONTINUE
C
C     CHECK FOR DUPLICATE ELEMENTS .. SUMMING ANY SUCH ENTRIES AND
C     PRINTING A WARNING MESSAGE ON UNIT NADV.
C     MOVE IS EQUAL TO THE NUMBER OF DUPLICATE ELEMENTS FOUND.
      MOVE = 0
C     THE LOOP ALSO CALCULATES THE LARGEST ELEMENT IN THE MATRIX,
C     THEMAX.
      THEMAX = ZERO
C     J1 IS POSITION IN ARRAYS OF FIRST NON-ZERO IN ROW.
      J1 = IPRIV4
      DO 220 I=1,N
         IF (I.NE.N) GO TO 140
         IPRIV4 = NZ + 1
         GO TO 160
  140    IPRIV4 = IW(I+1,1)
  160    LENGTH = IPRIV4 - J1
         IF (LENGTH.EQ.0) GO TO 220
         J2 = IPRIV4 - 1
         NEWJ1 = J1 - MOVE
         DO 200 JJ=J1,J2
            J = ICN(JJ)
            THEMAX = DMAX1(THEMAX,DABS(A(JJ)))
            IF (IKEEP(J,2).EQ.I) GO TO 180
C     FIRST TIME COLUMN HAS OCURRED IN CURRENT ROW.
            IKEEP(J,2) = I
            IKEEP(J,3) = JJ - MOVE - NEWJ1
            IF (MOVE.EQ.0) GO TO 200
C     SHIFT NECESSARY BECAUSE OF  PREVIOUS DUPLICATE ELEMENT.
            NEWPOS = JJ - MOVE
            A(NEWPOS) = A(JJ)
            ICN(NEWPOS) = ICN(JJ)
            GO TO 200
C     DUPLICATE ELEMENT.
  180       MOVE = MOVE + 1
            LENGTH = LENGTH - 1
            JAY = IKEEP(J,3) + NEWJ1
C     ** CODE FOR OUTPUT OF WARNING MESSAGE ************************
            IF (MOD(ISAVE/100,100).NE.0) THEN
               WRITE (REC,FMT=99998) I, J, A(JJ)
               CALL X04BAF(NADV,REC(1))
               CALL X04BAF(NADV,REC(2))
               CALL X04BAF(NADV,REC(3))
            END IF
C     ** END OF CODE FOR OUTPUT OF WARNING MESSAGE *****************
            IF (ABORT(4)) IFAIL = 13
C            write(0,*)' A(jay)=',A(jay),'  A(jj)=',A(jj)
            A(JAY) = A(JAY) + A(JJ)
            THEMAX = DMAX1(THEMAX,DABS(A(JAY)))
  200    CONTINUE
         IKEEP(I,1) = LENGTH
         J1 = IPRIV4
  220 CONTINUE
C     IF ABORT(4) IS .TRUE., DUPLICATE ELEMENTS ARE REGARDED AS
C     AN ERROR
      IF (IFAIL.GT.0) GO TO 320
C
C     KNUM IS ACTUAL NUMBER OF NON-ZEROS IN MATRIX WITH ANY
C     MULTIPLE ENTRIES COUNTED ONLY ONCE.
      KNUM = NZ - MOVE
      IF (.NOT.LBLOCK) GO TO 240
C
C     PERFORM BLOCK TRIANGULARISATION.
      IFAIL = ISAVE
      CALL F01BRY(N, ICN, A, LICN, IKEEP, IDISP, IKEEP(1,2),IKEEP(1,3),
     * IKEEP(1,5), IW(1,3), IW, ABORT(1), IFAIL)
C     ON EXIT FROM F01BRY IDISP(8)=NUMNZ, IDISP(9)=NUM,
C     IDISP(10) = LARGE.
      IF (IFAIL.NE.0) GO TO 340
      GO TO 300
C
C     BLOCK TRIANGULARIZATION NOT REQUESTED.
C     MOVE STRUCTURE TO END OF DATA ARRAYS IN PREPARATION FOR
C     M30Y12.
C     ALSO SET LENOFF(1) TO -1 AND SET PERMUTATION ARRAYS.
  240 DO 260 I=1,KNUM
         II = KNUM - I + 1
         NEWPOS = LICN - I + 1
         ICN(NEWPOS) = ICN(II)
         A(NEWPOS) = A(II)
  260 CONTINUE
      IDISP(1) = 1
      IDISP(2) = LICN - KNUM + 1
      DO 280 I=1,N
         IKEEP(I,2) = I
         IKEEP(I,3) = I
  280 CONTINUE
      IKEEP(1,5) = -1
C
C     PERFORM L/U DECOMOSITION ON DIAGONAL BLOCKS.
  300 IFAIL = ISAVE
      CALL M30Y12(N, ICN, A, LICN, IKEEP, IKEEP(1,4), IDISP,IKEEP(1,2),
     * IKEEP(1,3), IRN, LIRN, IW(1,2), IW(1,3),IW(1,4), IW(1,5), IW(1,6)
     *, IW(1,7), IW(1,8), IW, UPRIV,ABORT, IFAIL, THR)
C
C     ON EXIT FROM M30Y12 IDISP(3) TO IDISP(7) CONTAIN
C     IRNCP, ICNCP, IRANK, MINIRN AND MINICN RESPECTIVELY.
      IDISP(6) = MAX0(IDISP(6),NZ)
      IDISP(7) = MAX0(IDISP(7),NZ)
      IF (IFAIL.GT.0) GO TO 340
C
C     REORDER OFF-DIAGONAL BLOCKS ACCORDING TO PIVOT PERMUTATION.
      I1 = IDISP(1) - 1
      IF (I1.NE.0) CALL F01BRR(N, ICN, A, I1, IKEEP(1,5),IKEEP(1,2),
     * IKEEP(1,3), IW, IRN)
C
C     OPTIONALLY CALCULATE ELEMENT GROWTH ESTIMATE.
      I1 = IDISP(1)
      IEND = LICN - I1 + 1
      IF (GROW) CALL F01BRQ(N, ICN, A(I1), IEND, IKEEP, IKEEP(1,4),W)
C     INCREMENT GROWTH ESTIMATE BY ORIGINAL MAXIMUM ELEMENT.
      IF (GROW) W(1) = W(1) + THEMAX
      IF (IFAIL.EQ.0) GO TO 360
C
  320 CONTINUE
C     ** CODE FOR OUTPUT OF ERROR MESSAGES *************************
      IF (MOD(ISAVE/10,10).EQ.0) GO TO 340
      IF (IFAIL.EQ.-2) WRITE (REC,FMT=99992)
      IF (IFAIL.EQ.-1) WRITE (REC,FMT=99991)
      IF (IFAIL.EQ.8) WRITE (REC,FMT=99997) N
      IF (IFAIL.EQ.9) WRITE (REC,FMT=99996) NZ
      IF (IFAIL.EQ.10) WRITE (REC,FMT=99995) LICN, NZ
      IF (IFAIL.EQ.11) WRITE (REC,FMT=99994) LIRN, NZ
      IF (IFAIL.EQ.13) WRITE (REC,FMT=99993)
      IF (IFAIL.EQ.-1 .OR. IFAIL.EQ.-2 .OR. IFAIL.EQ.13 .OR.
     *    (IFAIL.GE.8 .AND. IFAIL.LE.11)) THEN
         CALL X04BAF(NERR,REC(1))
         CALL X04BAF(NERR,REC(2))
      END IF
C     ** END OF CODE FOR OUTPUT OF ERROR MESSAGES ******************
C
  340 IFAIL = P01ABF(ISAVE,IFAIL,SRNAME,0,P01REC)
  360 RETURN
99999 FORMAT (/' ON ENTRY IRN(I) OR ICN(I) IS OUT OF RANGE - I = ',I8,
     *  /'  A(I) = ',1P,D14.6,'  IRN(I) = ',I8,'  ICN(I) = ',I8)
99998 FORMAT (/' M28Y12 FOUND DUPLICATE ELEMENT WITH INDICES ',I6,', ',
     *  I6,/'  VALUE = ',1P,D14.6)
99997 FORMAT (/' ON ENTRY N .LE. 0 , N = ',I10)
99996 FORMAT (/' ON ENTRY NZ .LE. 0 , NZ = ',I10)
99995 FORMAT (/' ON ENTRY LICN .LT. NZ , LICN = ',I8,'  NZ = ',I8)
99994 FORMAT (/' ON ENTRY LIRN .LT. NZ , LIRN = ',I8,'  NZ = ',I8)
99993 FORMAT (/' DUPLICATE ELEMENTS FOUND ON INPUT - SEE ADVISORY MESS',
     *  'AGES')
99992 FORMAT (/' MATRIX IS NUMERICALLY SINGULAR - DECOMPOSITION COMPLE',
     *  'TED')
99991 FORMAT (/' MATRIX IS STRUCTURALLY SINGULAR - DECOMPOSITION COMPL',
     *  'ETED')
      END

      SUBROUTINEM30Y12(NN,ICN,A,LICN,LENR,LENRL,IDISP,IP,IQ,IRN,LIRN,LENC,IFIRST,LASTR,NEXTR,LASTC,NEXTC,IPTR,IPC,U,ABORT,IFAIL,THR)
      DOUBLEPRECISIONU
      DOUBLEPRECISIONTHR
      INTEGERIFAIL,LICN,LIRN,NN
      DOUBLEPRECISIONA(LICN)
      INTEGERICN(LICN),IDISP(11),IFIRST(NN),IP(NN),IPC(NN),IPTR(NN),IQ(NN),IRN(LIRN),LASTC(NN),LASTR(NN),LENC(NN),LENR(NN),LENRL(NN)
     *,NEXTC(NN),NEXTR(NN)
      LOGICALABORT(3)
      DOUBLEPRECISIONRMAX,AU,UMAX,ZERO
      INTEGER*8JCOST,KCOST,N8
      INTEGERDISPC,I1,I2,I,IACTIV,IBEG,ICNCP,IDISPC,IDUMMY,IEND,IFILL,IFIR,II,III,IJFIR,IJP1,IJPOS,ILAST,INDROW,IOP,IPIV,IPOS,IRANK,
     *IRNCP,IROWS,ISAVE,ISING,ISTART,ISW1,ISW,ITOP,J1,J2,J,JBEG,JCOUNT,JDIFF,JEND,JJ,JMORE,JNPOS,JOLD,JPIV,JPOS,JROOM,JVAL,JZER,JZER
     *O,K,L,LC,LENPIV,LL,LR,MINICN,MINIRN,MOREI,N,NBLOCK,NC,NERR,NNM1,NR,NUM,NZ2,NZ,NZCOL,NZMIN,NZPC,NZROW,OLDEND,OLDPIV,PIVEND,PIVO
     *T,PIVROW,ROWI
      DATANPZLAT/3/
      DATAUMAX/.9999D0/
      DATAZERO/0.0D0/
      ISAVE=IFAIL
      IFAIL=0
      CALLX04AAF(0,NERR)
      MINIRN=0
      MINICN=IDISP(1)-1
      MOREI=0
      IRANK=NN
      IRNCP=0
      ICNCP=0
      U=DMIN1(U,UMAX)
      U=DMAX1(U,ZERO)
      IBEG=IDISP(1)
      IACTIV=IDISP(2)
      NZROW=LICN-IACTIV+1
      MINICN=NZROW+MINICN
      NUM=1
      IPTR(1)=IACTIV
      IF(.NOT.((NN.NE.1)))GOTO09999
      NNM1=NN-1
      DO09996I=1,NNM1
      IF(IP(I).LT.0)NUM=NUM+1
      IPTR(I+1)=IPTR(I)+LENR(I)
09996 CONTINUE
09999 CONTINUE
      ILAST=0
      DO09993NBLOCK=1,NUM
      ISTART=ILAST+1
      DO09990IROWS=ISTART,NN
      IF(IP(IROWS).LT.0)GOTO80
09990 CONTINUE
      IROWS=NN
80    ILAST=IROWS
      N=ILAST-ISTART+1
      IF(.NOT.(N.EQ.1))GOTO09987
      LENRL(ILAST)=0
      ISING=ISTART
      IF(.NOT.((LENR(ILAST).EQ.0)))GOTO09984
      IRANK=IRANK-1
      ISING=-ISING
      IF(IFAIL.NE.-2.AND.IFAIL.NE.5)IFAIL=-1
      IF(.NOT.((ABORT(1))))GOTO09981
      IFAIL=1
      GOTO2020
09981 CONTINUE
      GOTO09983
09984 CONTINUE
      IF(.NOT.((A(IACTIV).EQ.ZERO)))GOTO09978
      ISING=-ISING
      IRANK=IRANK-1
      IPTR(ILAST)=0
      IF(IFAIL.NE.5)IFAIL=-2
      IF(.NOT.((ABORT(2))))GOTO09975
      IFAIL=2
      GOTO2020
09975 CONTINUE
      GOTO09977
09978 CONTINUE
      A(IBEG)=A(IACTIV)
      ICN(IBEG)=ICN(IACTIV)
      IACTIV=IACTIV+1
      IPTR(ISTART)=0
      IBEG=IBEG+1
      NZROW=NZROW-1
09977 CONTINUE
09983 CONTINUE
      LASTR(ISTART)=ISTART
      LASTC(ISTART)=ISING
      GOTO09986
09987 CONTINUE
      IF(.NOT.(ILAST.EQ.NN))GOTO09972
      ITOP=LICN
      GOTO09971
09972 CONTINUE
      ITOP=IPTR(ILAST+1)-1
09971 CONTINUE
      DO09969I=ISTART,ILAST
      LENRL(I)=0
      LENC(I)=0
09969 CONTINUE
      IF(.NOT.((ITOP-IACTIV.GE.LIRN)))GOTO09966
      MINIRN=ITOP-IACTIV+1
      PIVOT=ISTART-1
      GOTO1980
09966 CONTINUE
      DO09963II=IACTIV,ITOP
      I=ICN(II)
      LENC(I)=LENC(I)+1
09963 CONTINUE
      IPC(ILAST)=LIRN+1
      J1=ISTART+1
      DO09960JJ=J1,ILAST
      J=ILAST-JJ+J1-1
      IPC(J)=IPC(J+1)-LENC(J+1)
09960 CONTINUE
      DO09957INDROW=ISTART,ILAST
      J1=IPTR(INDROW)
      J2=J1+LENR(INDROW)-1
      IF(.NOT.((J1.LE.J2)))GOTO09954
      DO09951JJ=J1,J2
      J=ICN(JJ)
      IPOS=IPC(J)-1
      IRN(IPOS)=INDROW
      IPC(J)=IPOS
09951 CONTINUE
09954 CONTINUE
09957 CONTINUE
      DISPC=IPC(ISTART)
      NZCOL=LIRN-DISPC+1
      MINIRN=MAX0(NZCOL,MINIRN)
      NZMIN=1
      DO09948INZ=1,N
      IFIRST(INZ)=0
09948 CONTINUE
      DO09945II=ISTART,ILAST
      I=ILAST-II+ISTART
      NZ=LENR(I)
      IF(.NOT.(NZ.EQ.0))GOTO09942
      IPTR(I)=0
      LASTR(I)=0
      GOTO09941
09942 CONTINUE
      ISW=IFIRST(NZ)
      IFIRST(NZ)=I
      IF(.NOT.(ISW.LE.0))GOTO09939
      NEXTR(I)=0
      LASTR(I)=ISW
      GOTO09938
09939 CONTINUE
      NEXTR(I)=ISW
      LASTR(I)=LASTR(ISW)
      LASTR(ISW)=I
09938 CONTINUE
09941 CONTINUE
09945 CONTINUE
      DO09936PIVOT=ISTART,ILAST
      NSCAN=MIN(NPZLAT,ILAST+1-PIVOT)
      NZ2=NZMIN
      N8=N
      JCOST=N8**2
      DO660L=1,2
      LL=L
      ISCAN=0
      NZ=NZ2
09933 IF(.NOT.(ISCAN.LT.NSCAN.AND.NZ.LE.N))GOTO09932
      IJFIR=IFIRST(NZ)
      IF(.NOT.(IJFIR.GT.0))GOTO09930
      LL=2
09927 IF(.NOT.(ISCAN.LT.NSCAN.AND.IJFIR.NE.0))GOTO09926
      ISCAN=ISCAN+1
      I=IJFIR
      IJFIR=NEXTR(I)
      RMAX=ZERO
      J1=IPTR(I)+LENRL(I)
      IF(.NOT.(ISCAN.EQ.1))GOTO09924
      IJPOS=J1
      IPIV=I
      JPIV=ICN(J1)
09924 CONTINUE
      J2=IPTR(I)+LENR(I)-1
      DOJJ=J1,J2
      RMAX=DMAX1(RMAX,DABS(A(JJ)))
      ENDDO
      AU=RMAX*U
      DOJJ=J1,J2
      IF(DABS(A(JJ)).GT.AU.or.L.NE.1)THEN
      J=ICN(JJ)
      KCOST=(NZ-1)*(LENC(J)-1)
      IF((KCOST.LT.JCOST).or.(KCOST.EQ.JCOST.and.DABS(A(JJ)).GT.DABS(A(IJPOS))))THEN
      JCOST=KCOST
      IJPOS=JJ
      IPIV=I
      JPIV=J
      ENDIF
      ENDIF
      ENDDO
      GOTO09927
09926 CONTINUE
      GOTO09929
09930 CONTINUE
      IF(.NOT.(LL.EQ.1.AND.IJFIR.EQ.0))GOTO09921
      NZMIN=NZ+1
09921 CONTINUE
09929 CONTINUE
      NZ=NZ+1
      GOTO09933
09932 CONTINUE
      IF(ISCAN.EQ.NSCAN)GOTO820
      IRANK=IRANK-1
660   CONTINUE
      WRITE(*,662)ISCAN
662   Format(' ISCAN=',I8)
      IF(IFAIL.NE.-2.AND.IFAIL.NE.5)IFAIL=-1
      IRANK=IRANK-ILAST+PIVOT+1
      IF(.NOT.(ABORT(1)))GOTO09918
      IFAIL=1
      GOTO2020
09918 CONTINUE
      K=PIVOT-1
      I=ISTART
09915 IF(.NOT.(I.LE.ILAST.AND.LENRL(I).NE.0))GOTO09914
      IF(.NOT.(LASTR(I).EQ.0))GOTO09912
      K=K+1
      LASTR(I)=K
      IF(.NOT.(LENRL(I).NE.0))GOTO09909
      MINICN=MAX0(MINICN,NZROW+IBEG-1+MOREI+LENRL(I))
      IF(.NOT.(IACTIV-IBEG.LT.LENRL(I)))GOTO09906
      CALLF01BRS(A,ICN,IPTR(ISTART),N,IACTIV,ITOP,.TRUE.,ICNCP)
      IF(.NOT.(IACTIV-IBEG.LT.LENRL(I)))GOTO09903
      MOREI=MOREI+IBEG-IDISP(1)
      IBEG=IDISP(1)
      IFAIL=5
      IF(ABORT(3))GOTO2020
      IF(MOD(ISAVE/10,10).NE.0)WRITE(NERR,99997)
09903 CONTINUE
09906 CONTINUE
      J1=IPTR(I)
      J2=J1+LENRL(I)-1
      IPTR(I)=0
      DO09900JJ=J1,J2
      A(IBEG)=A(JJ)
      ICN(IBEG)=ICN(JJ)
      ICN(JJ)=0
      IBEG=IBEG+1
09900 CONTINUE
      NZROW=NZROW-LENRL(I)
09909 CONTINUE
09912 CONTINUE
      I=I+1
      GOTO09915
09914 CONTINUE
780   K=PIVOT-1
      DO09897I=ISTART,ILAST
      IF(.NOT.((LASTC(I).EQ.0)))GOTO09894
      K=K+1
      LASTC(I)=-K
      IF(K.EQ.ILAST)GOTO09935
09894 CONTINUE
09897 CONTINUE
820   ISING=PIVOT
      IF(.NOT.((A(IJPOS).EQ.ZERO)))GOTO09891
      Idisp(11)=IP(IPIV)
      Write(6,*)' I sing=',IP(IPIV)
      ISING=-ISING
      IF(IFAIL.NE.5)IFAIL=-2
      IF(.NOT.((ABORT(2))))GOTO09888
      IFAIL=2
      GOTO2020
09888 CONTINUE
09891 CONTINUE
      OLDPIV=IPTR(IPIV)+LENRL(IPIV)
      OLDEND=IPTR(IPIV)+LENR(IPIV)-1
      I1=IPC(JPIV)
      I2=I1+LENC(JPIV)-1
      DO09885II=I1,I2
      I=IRN(II)
      LR=LASTR(I)
      NR=NEXTR(I)
      IF(NR.NE.0)LASTR(NR)=LR
      IF(.NOT.(LR.GT.0))GOTO09882
      NEXTR(LR)=NR
      GOTO09881
09882 CONTINUE
      NZ=LENR(I)-LENRL(I)
      IF(.NOT.(NR.NE.0))GOTO09879
      IFIRST(NZ)=NR
      GOTO09878
09879 CONTINUE
      IFIRST(NZ)=0
09878 CONTINUE
09881 CONTINUE
09885 CONTINUE
      LASTC(JPIV)=ISING
      LASTR(IPIV)=PIVOT
      IF(.NOT.(OLDPIV.NE.IJPOS))GOTO09876
      AU=A(OLDPIV)
      A(OLDPIV)=A(IJPOS)
      A(IJPOS)=AU
      ICN(IJPOS)=ICN(OLDPIV)
      ICN(OLDPIV)=JPIV
09876 CONTINUE
      MINICN=MAX0(MINICN,NZROW+IBEG-1+MOREI+LENR(IPIV))
      IF(.NOT.(IACTIV-IBEG.LT.LENR(IPIV)))GOTO09873
      CALLF01BRS(A,ICN,IPTR(ISTART),N,IACTIV,ITOP,.TRUE.,ICNCP)
      OLDPIV=IPTR(IPIV)+LENRL(IPIV)
      OLDEND=IPTR(IPIV)+LENR(IPIV)-1
      IF(.NOT.(IACTIV-IBEG.LT.LENR(IPIV)))GOTO09870
      MOREI=MOREI+IBEG-IDISP(1)
      IBEG=IDISP(1)
      IFAIL=5
      IF(ABORT(3))GOTO2020
      IF(MOD(ISAVE/10,10).NE.0)WRITE(NERR,99997)
      IF(.NOT.(IACTIV-IBEG.LT.LENR(IPIV)))GOTO09867
      IFAIL=4
      GOTO2020
09867 CONTINUE
09870 CONTINUE
09873 CONTINUE
      IJPOS=0
      J1=IPTR(IPIV)
      DO09864JJ=J1,OLDEND
      A(IBEG)=A(JJ)
      ICN(IBEG)=ICN(JJ)
      IF(.NOT.((IJPOS.EQ.0)))GOTO09861
      IF(ICN(JJ).EQ.JPIV)IJPOS=IBEG
      ICN(JJ)=0
      GOTO09860
09861 CONTINUE
      K=IBEG-IJPOS
      J=ICN(JJ)
      ICN(JJ)=IQ(J)
      IQ(J)=-K
09860 CONTINUE
      IBEG=IBEG+1
09864 CONTINUE
      IJP1=IJPOS+1
      PIVEND=IBEG-1
      LENPIV=PIVEND-IJPOS
      NZROW=NZROW-LENRL(IPIV)-1
      IPTR(IPIV)=OLDPIV+1
      IF(LENPIV.EQ.0)IPTR(IPIV)=0
      DO09858JJ=IJPOS,PIVEND
      J=ICN(JJ)
      I1=IPC(J)
      LENC(J)=LENC(J)-1
      I2=IPC(J)+LENC(J)-1
      IF(.NOT.((I2.GE.I1)))GOTO09855
      DO09852II=I1,I2
      IF(.NOT.((IRN(II).EQ.IPIV)))GOTO09849
      IRN(II)=IRN(I2+1)
      GOTO09851
09849 CONTINUE
09852 CONTINUE
09851 CONTINUE
09855 CONTINUE
      IRN(I2+1)=0
09858 CONTINUE
      NZCOL=NZCOL-LENPIV-1
      NZPC=LENC(JPIV)
      IF(.NOT.(NZPC.NE.0))GOTO09846
      DO09843III=1,NZPC
      II=IPC(JPIV)+III-1
      I=IRN(II)
      J1=IPTR(I)+LENRL(I)
      IEND=IPTR(I)+LENR(I)-1
      JJ=J1
09840 IF(.NOT.(ICN(JJ).NE.JPIV.AND.JJ.LE.IEND))GOTO09839
      JJ=JJ+1
      GOTO09840
09839 CONTINUE
      IF(.NOT.(JJ.LE.IEND))GOTO09837
      IF(.NOT.(A(IJPOS).EQ.ZERO))GOTO09834
      AU=ZERO
      GOTO09833
09834 CONTINUE
      AU=-A(JJ)/A(IJPOS)
09833 CONTINUE
      A(JJ)=A(J1)
      A(J1)=AU
      ICN(JJ)=ICN(J1)
      ICN(J1)=JPIV
      LENRL(I)=LENRL(I)+1
09837 CONTINUE
      IF(.NOT.(LENPIV.NE.0))GOTO09831
      ROWI=J1+1
      IOP=0
      IF(.NOT.(ROWI.LE.IEND))GOTO09828
      DO1140JJ=ROWI,IEND
      J=ICN(JJ)
      IF(IQ(J).GT.0)GOTO1140
      IOP=IOP+1
      PIVROW=IJPOS-IQ(J)
      A(JJ)=A(JJ)+AU*A(PIVROW)
      ICN(PIVROW)=-ICN(PIVROW)
1140  CONTINUE
09828 CONTINUE
      IFILL=LENPIV-IOP
      DO1162JJ=IJP1,PIVEND
      J=ICN(JJ)
      IF(J.LT.0)GOTO1162
      IF(.NOT.(DABS(AU*A(JJ)).LT.THR))GOTO09825
      ICN(JJ)=-J
      IFILL=IFILL-1
09825 CONTINUE
1162  CONTINUE
      IF(.NOT.(IFILL.NE.0))GOTO09822
      MINICN=MAX0(MINICN,MOREI+IBEG-1+NZROW+IFILL+LENR(I))
      DO09819JDIFF=1,IFILL
      JNPOS=IEND+JDIFF
      IF(JNPOS.GT.LICN)GOTO1200
      IF(ICN(JNPOS).NE.0)GOTO1200
09819 CONTINUE
      IEND=IEND+1
      GOTO1360
1200  JMORE=IFILL-JDIFF+1
      I1=IPTR(I)
      DO09816JDIFF=1,JMORE
      JNPOS=I1-JDIFF
      IF(JNPOS.LT.IACTIV)GOTO1240
      IF(ICN(JNPOS).NE.0)GOTO1260
09816 CONTINUE
1240  JNPOS=I1-JMORE
      GOTO1280
1260  JNPOS=IACTIV-LENR(I)-IFILL
1280  continue
      IF(.NOT.(JNPOS.LT.IBEG))GOTO09813
      CALLF01BRS(A,ICN,IPTR(ISTART),N,IACTIV,ITOP,.TRUE.,ICNCP)
      I1=IPTR(I)
      IEND=I1+LENR(I)-1
      JNPOS=IACTIV-LENR(I)-IFILL
      IF(.NOT.(JNPOS.LT.IBEG))GOTO09810
      MOREI=MOREI+IBEG-IDISP(1)-LENPIV-1
      IFAIL=5
      IF(ABORT(3))GOTO2020
      IF(MOD(ISAVE/10,10).NE.0)WRITE(NERR,99997)
      IBEG=IDISP(1)
      ICN(IBEG)=JPIV
      A(IBEG)=A(IJPOS)
      IJPOS=IBEG
      DO09807JJ=IJP1,PIVEND
      IBEG=IBEG+1
      A(IBEG)=A(JJ)
      ICN(IBEG)=ICN(JJ)
09807 CONTINUE
      IJP1=IJPOS+1
      PIVEND=IBEG
      IBEG=IBEG+1
      IF(.NOT.(JNPOS.LT.IBEG))GOTO09804
      IFAIL=4
      GOTO2020
09804 CONTINUE
09810 CONTINUE
09813 CONTINUE
      IACTIV=MIN0(IACTIV,JNPOS)
      IPTR(I)=JNPOS
      DO09801JJ=I1,IEND
      A(JNPOS)=A(JJ)
      ICN(JNPOS)=ICN(JJ)
      JNPOS=JNPOS+1
      ICN(JJ)=0
09801 CONTINUE
      IEND=JNPOS
09822 CONTINUE
1360  NZROW=NZROW+IFILL
      IENBEG=IEND
      DO09798JJ=IJP1,PIVEND
      J=ICN(JJ)
      IF(.NOT.(J.GT.0))GOTO09795
      A(IEND)=AU*A(JJ)
      ICN(IEND)=J
      IEND=IEND+1
      MINIRN=MAX0(MINIRN,NZCOL+LENC(J)+1)
      JEND=IPC(J)+LENC(J)
      JROOM=NZPC-III+1+LENC(J)
      IF(.NOT.((JEND.LE.LIRN.AND.IRN(min(LIRN,JEND)).NE.0).or.JEND.GT.LIRN))GOTO09792
      IF(.NOT.(JROOM.GE.DISPC))GOTO09789
      CALLF01BRS(A,IRN,IPC(ISTART),N,DISPC,LIRN,.FALSE.,IRNCP)
      IF(.NOT.(JROOM.GE.DISPC))GOTO09786
      JROOM=DISPC-1
      IF(.NOT.(JROOM.LT.LENC(J)+1))GOTO09783
      GOTO1980
09783 CONTINUE
09786 CONTINUE
09789 CONTINUE
      JBEG=IPC(J)
      JEND=IPC(J)+LENC(J)-1
      JZERO=DISPC-1
      DISPC=DISPC-JROOM
      IDISPC=DISPC
      DO09780II=JBEG,JEND
      IRN(IDISPC)=IRN(II)
      IRN(II)=0
      IDISPC=IDISPC+1
09780 CONTINUE
      IPC(J)=DISPC
      JEND=IDISPC
      DO09777II=JEND,JZERO
      IRN(II)=0
09777 CONTINUE
09792 CONTINUE
      IRN(JEND)=I
      NZCOL=NZCOL+1
      LENC(J)=LENC(J)+1
      GOTO09794
09795 CONTINUE
      ICN(JJ)=-J
09794 CONTINUE
09798 CONTINUE
      LENR(I)=LENR(I)+IFILL
09831 CONTINUE
09843 CONTINUE
      I1=IPC(JPIV)
      I2=IPC(JPIV)+LENC(JPIV)-1
      NZCOL=NZCOL-LENC(JPIV)
      DO09774II=I1,I2
      I=IRN(II)
      IRN(II)=0
      NZ=LENR(I)-LENRL(I)
      IF(.NOT.(NZ.EQ.0))GOTO09771
      LASTR(I)=0
      GOTO09770
09771 CONTINUE
      IFIR=IFIRST(NZ)
      IFIRST(NZ)=I
      IF(.NOT.(IFIR.NE.0))GOTO09768
      LASTR(I)=LASTR(IFIR)
      NEXTR(I)=IFIR
      LASTR(IFIR)=I
      GOTO09767
09768 CONTINUE
      LASTR(I)=0
      NEXTR(I)=0
      NZMIN=MIN0(NZMIN,NZ)
09767 CONTINUE
09770 CONTINUE
09774 CONTINUE
09846 CONTINUE
      IPC(JPIV)=0
      IF(.NOT.((LENPIV.NE.0)))GOTO09765
      NZROW=NZROW-LENPIV
      JVAL=IJP1
      JZER=IPTR(IPIV)
      IPTR(IPIV)=0
      DO09762JCOUNT=1,LENPIV
      J=ICN(JVAL)
      IQ(J)=ICN(JZER)
      ICN(JZER)=0
      JVAL=JVAL+1
      JZER=JZER+1
09762 CONTINUE
756   Format(' ICN LUDI:',10I6)
09765 CONTINUE
09936 CONTINUE
09935 CONTINUE
      IF(ILAST.NE.NN)IACTIV=IPTR(ILAST+1)
09986 CONTINUE
09993 CONTINUE
      IF(.NOT.(IRANK.NE.NN))GOTO09759
      DO09756I=1,NN
      IF(.NOT.(LASTC(I).LE.0))GOTO09753
      ISING=-LASTC(I)
      IQ(ISING)=-IQ(ISING)
      LASTC(I)=ISING
09753 CONTINUE
09756 CONTINUE
09759 CONTINUE
      ISTART=IDISP(1)
      IEND=IBEG-1
      DO09750JJ=ISTART,IEND
      JOLD=ICN(JJ)
      ICN(JJ)=LASTC(JOLD)
09750 CONTINUE
      DO09747II=1,NN
      I=LASTR(II)
      NEXTR(I)=LENR(II)
      NEXTC(I)=LENRL(II)
09747 CONTINUE
      DO09744I=1,NN
      LENRL(I)=NEXTC(I)
      LENR(I)=NEXTR(I)
09744 CONTINUE
      DO09741II=1,NN
      I=LASTR(II)
      J=LASTC(II)
      NEXTR(I)=IABS(IP(II))
      NEXTC(J)=IABS(IQ(II))
09741 CONTINUE
      DO09738I=1,NN
      IF(IP(I).LT.0)NEXTR(I)=-NEXTR(I)
      IP(I)=NEXTR(I)
      IF(IQ(I).LT.0)NEXTC(I)=-NEXTC(I)
      IQ(I)=NEXTC(I)
09738 CONTINUE
      IP(NN)=IABS(IP(NN))
      IDISP(2)=IEND
      IF(IFAIL.NE.5)GOTO2060
      IF(MOD(ISAVE/10,10).NE.0)WRITE(NERR,99991)MINICN
      GOTO2060
1980  continue
      IF(.NOT.(IFAIL.NE.5))GOTO09735
      IFAIL=3
      GOTO09734
09735 CONTINUE
      IFAIL=6
09734 CONTINUE
2020  CONTINUE
      IF(.NOT.(MOD(ISAVE/10,10).NE.0))GOTO09732
      GOTO(09729,09728,09727,09726,09725,09724),IFAIL
      GOTO09723
09729 CONTINUE
      WRITE(NERR,99999)
      GOTO09723
09728 CONTINUE
      WRITE(NERR,99998)
      GOTO09723
09727 CONTINUE
      WRITE(NERR,99996)
      GOTO09723
09726 CONTINUE
      WRITE(NERR,99995)
      GOTO09723
09725 CONTINUE
      WRITE(NERR,99994)
      GOTO09723
09724 CONTINUE
      WRITE(NERR,99993)
09723 CONTINUE
      IF(.NOT.(IFAIL.GT.2))GOTO09722
      PIVOT=PIVOT-ISTART+1
      WRITE(NERR,99992)PIVOT,NBLOCK,ISTART,ILAST
      IF(PIVOT.EQ.0)WRITE(NERR,99990)MINIRN
09722 CONTINUE
09732 CONTINUE
      IDISP(2)=IACTIV
2060  IDISP(3)=IRNCP
      IDISP(4)=ICNCP
      IDISP(5)=IRANK
      IDISP(6)=MINIRN
      IDISP(7)=MINICN
      RETURN
99999 FORMAT(50H0MATRIX IS STRUCTURALLY SINGULAR - DECOMPOSITION A,6HBORTED)
99998 FORMAT(50H0MATRIX IS NUMERICALLY SINGULAR - DECOMPOSITION AB,5HORTED)
99997 FORMAT(48H0LU DECOMPOSITION DESTROYED TO CREATE MORE SPACE)
99996 FORMAT(17H0LIRN TOO SMALL -)
99995 FORMAT(22H0LICN MUCH TOO SMALL -)
99994 FORMAT(17H0LICN TOO SMALL -)
99993 FORMAT(26H0LICN AND LIRN TOO SMALL -)
99992 FORMAT(33H  DECOMPOSITION ABORTED AT STAGE ,I5,9H IN BLOCK,1H ,I5/17H  WITH FIRST ROW ,I5,14H AND LAST ROW ,I5)
99991 FORMAT(17H0LICN TOO SMALL -/29H  FOR SUCCESSFUL DECOMPOSITIO,23HN SET LICN TO AT LEAST ,I8)
99990 FORMAT(35H  TO CONTINUE SET LIRN TO AT LEAST ,I8)
      END

      INTEGER FUNCTION P01ABF(IFAIL,IERROR,SRNAME,NREC,REC)
C     MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.
C     MARK 13 REVISED. IER-621 (APR 1988).
C     MARK 13B REVISED. IER-668 (AUG 1988).
C
C     P01ABF is the error-handling routine for the NAG Library.
C
C     P01ABF either returns the value of IERROR through the routine
C     name (soft failure), or terminates execution of the program
C     (hard failure). Diagnostic messages may be output.
C
C     If IERROR = 0 (successful exit from the calling routine),
C     the value 0 is returned through the routine name, and no
C     message is output
C
C     If IERROR is non-zero (abnormal exit from the calling routine),
C     the action taken depends on the value of IFAIL.
C
C     IFAIL =  1: soft failure, silent exit (i.e. no messages are
C                 output)
C     IFAIL = -1: soft failure, noisy exit (i.e. messages are output)
C     IFAIL =-13: soft failure, noisy exit but standard messages from
C                 P01ABF are suppressed
C     IFAIL =  0: hard failure, noisy exit
C
C     For compatibility with certain routines included before Mark 12
C     P01ABF also allows an alternative specification of IFAIL in which
C     it is regarded as a decimal integer with least significant digits
C     cba. Then
C
C     a = 0: hard failure  a = 1: soft failure
C     b = 0: silent exit   b = 1: noisy exit
C
C     except that hard failure now always implies a noisy exit.
C
C     S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office.
C
C     .. Scalar Arguments ..
      INTEGER                 IERROR, IFAIL, NREC
      CHARACTER*(*)           SRNAME
C     .. Array Arguments ..
      CHARACTER*(*)           REC(*)
C     .. Local Scalars ..
      INTEGER                 I, NERR
      CHARACTER*72            MESS
C     .. External Subroutines ..
      EXTERNAL                P01ABZ, X04AAF, X04BAF
C     .. Intrinsic Functions ..
      INTRINSIC               ABS, MOD
C     .. Executable Statements ..
      IF (IERROR.NE.0) THEN
C        Abnormal exit from calling routine
         IF (IFAIL.EQ.-1 .OR. IFAIL.EQ.0 .OR. IFAIL.EQ.-13 .OR.
     *       (IFAIL.GT.0 .AND. MOD(IFAIL/10,10).NE.0)) THEN
C           Noisy exit
            CALL X04AAF(0,NERR)
            DO 20 I = 1, NREC
               CALL X04BAF(NERR,REC(I))
   20       CONTINUE
            IF (IFAIL.NE.-13) THEN
               WRITE (MESS,FMT=99999) SRNAME, IERROR
               CALL X04BAF(NERR,MESS)
               IF (ABS(MOD(IFAIL,10)).NE.1) THEN
C                 Hard failure
                  CALL X04BAF(NERR,
     *                     ' ** NAG hard failure - execution terminated'
     *                        )
                  CALL P01ABZ
               ELSE
C                 Soft failure
                  CALL X04BAF(NERR,
     *                        ' ** NAG soft failure - control returned')
               END IF
            END IF
         END IF
      END IF
      P01ABF = IERROR
      RETURN
C
99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL',
     *  ' =',I6)
      END

      SUBROUTINE P01ABZ
C     MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.
C
C     Terminates execution when a hard failure occurs.
C
C     ******************** IMPLEMENTATION NOTE ********************
C     The following STOP statement may be replaced by a call to an
C     implementation-dependent routine to display a message and/or
C     to abort the program.
C     *************************************************************
C     .. Executable Statements ..
      STOP
      END
!p0* x0* routines from NAG

      DOUBLE PRECISION FUNCTION X01AAF(X)
C     MARK 8 RE-ISSUE. NAG COPYRIGHT 1980.
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C
C     RETURNS THE VALUE OF THE MATHEMATICAL CONSTANT PI.
C
C     X IS A DUMMY ARGUMENT
C
C     IT MAY BE NECESSARY TO ROUND THE REAL CONSTANT IN THE
C     ASSIGNMENT STATEMENT TO A SMALLER NUMBER OF SIGNIFICANT
C     DIGITS IN ORDER TO AVOID COMPILATION PROBLEMS.  IF SO, THEN
C     THE NUMBER OF DIGITS RETAINED SHOULD NOT BE LESS THAN
C     .     2 + INT(FLOAT(IT)*ALOG10(IB))
C     WHERE  IB  IS THE BASE FOR THE REPRESENTATION OF FLOATING-
C     .             POINT NUMBERS
C     . AND  IT  IS THE NUMBER OF IB-ARY DIGITS IN THE MANTISSA OF
C     .             A FLOATING-POINT NUMBER.
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION                 X
C     .. Executable Statements ..
      X01AAF = 3.14159265358979323846264338328D0
      RETURN
      END

      DOUBLE PRECISION FUNCTION X02AJF()
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C
C     RETURNS  (1/2)*B**(1-P)  IF ROUNDS IS .TRUE.
C     RETURNS  B**(1-P)  OTHERWISE
C
      DOUBLE PRECISION X02CON
      DATA X02CON /1.11022302462516D-16 /
C     .. Executable Statements ..
      X02AJF = X02CON
      RETURN
      END

      DOUBLE PRECISION FUNCTION X02AMF()
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C
C     RETURNS THE 'SAFE RANGE' PARAMETER
C     I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT
C     FOR ANY X WHICH SATISFIES X.GE.Z AND X.LE.1/Z
C     THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER
C     ERROR
C
C        -X
C        1.0/X
C        SQRT(X)
C        LOG(X)
C        EXP(LOG(X))
C        Y**(LOG(X)/LOG(Y)) FOR ANY Y
C
      DOUBLE PRECISION X02CON
      DATA X02CON /2.22507385850721D-308 /
C     .. Executable Statements ..
      X02AMF = X02CON
      RETURN
      END

      SUBROUTINE X04AAF(I,NERR)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 7C REVISED IER-190 (MAY 1979)
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 14 REVISED. IER-829 (DEC 1989).
C     IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER
C     (STORED IN NERR1).
C     IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO
C     VALUE SPECIFIED BY NERR.
C
C     .. Scalar Arguments ..
      INTEGER           I, NERR
C     .. Local Scalars ..
      INTEGER           NERR1
C     .. Save statement ..
      SAVE              NERR1
C     .. Data statements ..
      DATA              NERR1/0/
C     .. Executable Statements ..
      IF (I.EQ.0) NERR = NERR1
      IF (I.EQ.1) NERR1 = NERR
      RETURN
      END

      SUBROUTINE X04BAF(NOUT,REC)
C     MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986.
C
C     X04BAF writes the contents of REC to the unit defined by NOUT.
C
C     Trailing blanks are not output, except that if REC is entirely
C     blank, a single blank character is output.
C     If NOUT.lt.0, i.e. if NOUT is not a valid Fortran unit identifier,
C     then no output occurs.
C
C     .. Scalar Arguments ..
      INTEGER           NOUT
      CHARACTER*(*)     REC
C     .. Local Scalars ..
      INTEGER           I
C     .. Intrinsic Functions ..
      INTRINSIC         LEN
C     .. Executable Statements ..
      IF (NOUT.GE.0) THEN
C        Remove trailing blanks
         DO 20 I = LEN(REC), 2, -1
            IF (REC(I:I).NE.' ') GO TO 40
   20    CONTINUE
C        Write record to external file
   40    WRITE (NOUT,FMT=99999) REC(1:I)
      END IF
      RETURN
C
99999 FORMAT (A)
      END


!polyfits
! E02ACF
! E02ADF
! E02ADZ
! E02AEF
! E02AFF
! E02AGF

      SUBROUTINE ADDCST (NCC,LCC,N,X,Y, LWK,IWK,LIST,LPTR,
     .                   LEND, IER)
      INTEGER NCC, LCC(*), N, LWK, IWK(LWK), LIST(*),
     .        LPTR(*), LEND(N), IER
      DOUBLE PRECISION X(N), Y(N)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   11/12/94
C
C   This subroutine provides for creation of a constrained
C Delaunay triangulation which, in some sense, covers an
C arbitrary connected region R rather than the convex hull
C of the nodes.  This is achieved simply by forcing the
C presence of certain adjacencies (triangulation arcs) cor-
C responding to constraint curves.  The union of triangles
C coincides with the convex hull of the nodes, but triangles
C in R can be distinguished from those outside of R.  The
C only modification required to generalize the definition of
C the Delaunay triangulation is replacement of property 5
C (refer to TRMESH) by the following:
C
C  5')  If a node is contained in the interior of the cir-
C       cumcircle of a triangle, then every interior point
C       of the triangle is separated from the node by a
C       constraint arc.
C
C   In order to be explicit, we make the following defini-
C tions.  A constraint region is the open interior of a
C simple closed positively oriented polygonal curve defined
C by an ordered sequence of three or more distinct nodes
C (constraint nodes) P(1),P(2),...,P(K), such that P(I) is
C adjacent to P(I+1) for I = 1,...,K with P(K+1) = P(1).
C Thus, the constraint region is on the left (and may have
C nonfinite area) as the sequence of constraint nodes is
C traversed in the specified order.  The constraint regions
C must not contain nodes and must not overlap.  The region
C R is the convex hull of the nodes with constraint regions
C excluded.
C
C   Note that the terms boundary node and boundary arc are
C reserved for nodes and arcs on the boundary of the convex
C hull of the nodes.
C
C   The algorithm is as follows:  given a triangulation
C which includes one or more sets of constraint nodes, the
C corresponding adjacencies (constraint arcs) are forced to
C be present (Subroutine EDGE).  Any additional new arcs
C required are chosen to be locally optimal (satisfy the
C modified circumcircle property).
C
C
C On input:
C
C       NCC = Number of constraint curves (constraint re-
C             gions).  NCC .GE. 0.
C
C       LCC = Array of length NCC (or dummy array of length
C             1 if NCC = 0) containing the index (for X, Y,
C             and LEND) of the first node of constraint I in
C             LCC(I) for I = 1 to NCC.  Thus, constraint I
C             contains K = LCC(I+1) - LCC(I) nodes, K .GE.
C             3, stored in (X,Y) locations LCC(I), ...,
C             LCC(I+1)-1, where LCC(NCC+1) = N+1.
C
C       N = Number of nodes in the triangulation, including
C           constraint nodes.  N .GE. 3.
C
C       X,Y = Arrays of length N containing the coordinates
C             of the nodes with non-constraint nodes in the
C             first LCC(1)-1 locations, followed by NCC se-
C             quences of constraint nodes.  Only one of
C             these sequences may be specified in clockwise
C             order to represent an exterior constraint
C             curve (a constraint region with nonfinite
C             area).
C
C The above parameters are not altered by this routine.
C
C       LWK = Length of IWK.  This must be at least 2*NI
C             where NI is the maximum number of arcs which
C             intersect a constraint arc to be added.  NI
C             is bounded by N-3.
C
C       IWK = Integer work array of length LWK (used by
C             Subroutine EDGE to add constraint arcs).
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C On output:
C
C       LWK = Required length of IWK unless IER = 1 or IER =
C             3.  In the case of IER = 1, LWK is not altered
C             from its input value.
C
C       IWK = Array containing the endpoint indexes of the
C             new arcs which were swapped in by the last
C             call to Subroutine EDGE.
C
C       LIST,LPTR,LEND = Triangulation data structure with
C                        all constraint arcs present unless
C                        IER .NE. 0.  These arrays are not
C                        altered if IER = 1.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if NCC, N, or an LCC entry is outside
C                     its valid range, or LWK .LT. 0 on
C                     input.
C             IER = 2 if more space is required in IWK.
C             IER = 3 if the triangulation data structure is
C                     invalid, or failure (in EDGE or OPTIM)
C                     was caused by collinear nodes on the
C                     convex hull boundary.  An error mes-
C                     sage is written to logical unit 6 in
C                     this case.
C             IER = 4 if intersecting constraint arcs were
C                     encountered.
C             IER = 5 if a constraint region contains a
C                     node.
C
C Modules required by ADDCST:  EDGE, LEFT, LSTPTR, OPTIM,
C                                SWAP, SWPTST
C
C Intrinsic functions called by ADDCST:  ABS, MAX
C
C***********************************************************
C
      INTEGER I, IFRST, ILAST, K, KBAK, KFOR, KN, LCCIP1,
     .        LP, LPB, LPF, LPL, LW, LWD2, N1, N2
      LWD2 = LWK/2
C
C Test for errors in input parameters.
C
      IER = 1
      IF (NCC .LT. 0  .OR.  LWK .LT. 0) RETURN
      IF (NCC .EQ. 0) THEN
        IF (N .LT. 3) RETURN
        LWK = 0
        GO TO 9
      ELSE
        LCCIP1 = N+1
        DO 1 I = NCC,1,-1
          IF (LCCIP1 - LCC(I) .LT. 3) RETURN
          LCCIP1 = LCC(I)
    1     CONTINUE
        IF (LCCIP1 .LT. 1) RETURN
      ENDIF
C
C Force the presence of constraint arcs.  The outer loop is
C   on constraints in reverse order.  IFRST and ILAST are
C   the first and last nodes of constraint I.
C
      LWK = 0
      IFRST = N+1
      DO 3 I = NCC,1,-1
        ILAST = IFRST - 1
        IFRST = LCC(I)
C
C   Inner loop on constraint arcs N1-N2 in constraint I.
C
        N1 = ILAST
        DO 2 N2 = IFRST,ILAST
          LW = LWD2
          CALL EDGE (N1,N2,X,Y, LW,IWK,LIST,LPTR,LEND, IER)
          LWK = MAX(LWK,2*LW)
          IF (IER .EQ. 4) IER = 3
          IF (IER .NE. 0) RETURN
          N1 = N2
    2     CONTINUE
    3   CONTINUE
C
C Test for errors.  The outer loop is on constraint I with
C   first and last nodes IFRST and ILAST, and the inner loop
C   is on constraint nodes K with (KBAK,K,KFOR) a subse-
C   quence of constraint I.
C
      IER = 4
      IFRST = N+1
      DO 8 I = NCC,1,-1
        ILAST = IFRST - 1
        IFRST = LCC(I)
        KBAK = ILAST
        DO 7 K = IFRST,ILAST
          KFOR = K + 1
          IF (K .EQ. ILAST) KFOR = IFRST
C
C   Find the LIST pointers LPF and LPB of KFOR and KBAK as
C     neighbors of K.
C
          LPF = 0
          LPB = 0
          LPL = LEND(K)
          LP = LPL
C
    4     LP = LPTR(LP)
            KN = ABS(LIST(LP))
            IF (KN .EQ. KFOR) LPF = LP
            IF (KN .EQ. KBAK) LPB = LP
            IF (LP .NE. LPL) GO TO 4
C
C   A pair of intersecting constraint arcs was encountered
C     if and only if a constraint arc is missing (introduc-
C     tion of the second caused the first to be swapped out).
C
          IF (LPF .EQ. 0  .OR.  LPB .EQ. 0) RETURN
C
C   Loop on neighbors KN of node K which follow KFOR and
C     precede KBAK.  The constraint region contains no nodes
C     if and only if all such nodes KN are in constraint I.
C
          LP = LPF
    5     LP = LPTR(LP)
            IF (LP .EQ. LPB) GO TO 6
            KN = ABS(LIST(LP))
            IF (KN .LT. IFRST  .OR.  KN .GT. ILAST) GO TO 10
            GO TO 5
C
C   Bottom of loop.
C
    6     KBAK = K
    7     CONTINUE
    8   CONTINUE
C
C No errors encountered.
C
    9 IER = 0
      RETURN
C
C A constraint region contains a node.
C
   10 IER = 5
      RETURN
      END
      SUBROUTINE ADDNOD (K,XK,YK,IST,NCC, LCC,N,X,Y,LIST,
     .                   LPTR,LEND,LNEW, IER)
      INTEGER K, IST, NCC, LCC(*), N, LIST(*), LPTR(*),
     .        LEND(*), LNEW, IER
      DOUBLE PRECISION XK, YK, X(*), Y(*)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/27/98
C
C   Given a triangulation of N nodes in the plane created by
C Subroutine TRMESH or TRMSHR, this subroutine updates the
C data structure with the addition of a new node in position
C K.  If node K is inserted into X and Y (K .LE. N) rather
C than appended (K = N+1), then a corresponding insertion
C must be performed in any additional arrays associated
C with the nodes.  For example, an array of data values Z
C must be shifted down to open up position K for the new
C value:  set Z(I+1) to Z(I) for I = N,N-1,...,K.  For
C optimal efficiency, new nodes should be appended whenever
C possible.  Insertion is necessary, however, to add a non-
C constraint node when constraints are present (refer to
C Subroutine ADDCST).
C
C   Note that a constraint node cannot be added by this
C routine.  In order to insert a constraint node, it is
C necessary to add the node with no constraints present
C (call this routine with NCC = 0), update LCC by increment-
C ing the appropriate entries, and then create (or restore)
C the constraints by a call to ADDCST.
C
C   The algorithm consists of the following steps:  node K
C is located relative to the triangulation (TRFIND), its
C index is added to the data structure (INTADD or BDYADD),
C and a sequence of swaps (SWPTST and SWAP) are applied to
C the arcs opposite K so that all arcs incident on node K
C and opposite node K (excluding constraint arcs) are local-
C ly optimal (satisfy the circumcircle test).  Thus, if a
C (constrained) Delaunay triangulation is input, a (con-
C strained) Delaunay triangulation will result.  All indexes
C are incremented as necessary for an insertion.
C
C
C On input:
C
C       K = Nodal index (index for X, Y, and LEND) of the
C           new node to be added.  1 .LE. K .LE. LCC(1).
C           (K .LE. N+1 if NCC=0).
C
C       XK,YK = Cartesian coordinates of the new node (to be
C               stored in X(K) and Y(K)).  The node must not
C               lie in a constraint region.
C
C       IST = Index of a node at which TRFIND begins the
C             search.  Search time depends on the proximity
C             of this node to node K.  1 .LE. IST .LE. N.
C
C       NCC = Number of constraint curves.  NCC .GE. 0.
C
C The above parameters are not altered by this routine.
C
C       LCC = List of constraint curve starting indexes (or
C             dummy array of length 1 if NCC = 0).  Refer to
C             Subroutine ADDCST.
C
C       N = Number of nodes in the triangulation before K is
C           added.  N .GE. 3.  Note that N will be incre-
C           mented following the addition of node K.
C
C       X,Y = Arrays of length at least N+1 containing the
C             Cartesian coordinates of the nodes in the
C             first N positions with non-constraint nodes
C             in the first LCC(1)-1 locations if NCC > 0.
C
C       LIST,LPTR,LEND,LNEW = Data structure associated with
C                             the triangulation of nodes 1
C                             to N.  The arrays must have
C                             sufficient length for N+1
C                             nodes.  Refer to TRMESH.
C
C On output:
C
C       LCC = List of constraint curve starting indexes in-
C             cremented by 1 to reflect the insertion of K
C             unless NCC = 0 or (IER .NE. 0 and IER .NE.
C             -4).
C
C       N = Number of nodes in the triangulation including K
C           unless IER .NE. 0 and IER .NE. -4.  Note that
C           all comments refer to the input value of N.
C
C       X,Y = Arrays updated with the insertion of XK and YK
C             in the K-th positions (node I+1 was node I be-
C             fore the insertion for I = K to N if K .LE. N)
C             unless IER .NE. 0 and IER .NE. -4.
C
C       LIST,LPTR,LEND,LNEW = Data structure updated with
C                             the addition of node K unless
C                             IER .NE. 0 and IER .NE. -4.
C
C       IER = Error indicator:
C             IER =  0 if no errors were encountered.
C             IER = -1 if K, IST, NCC, N, or an LCC entry is
C                      outside its valid range on input.
C             IER = -2 if all nodes (including K) are col-
C                      linear.
C             IER =  L if nodes L and K coincide for some L.
C             IER = -3 if K lies in a constraint region.
C             IER = -4 if an error flag is returned by SWAP
C                      implying that the triangulation
C                      (geometry) was bad on input.
C
C             The errors conditions are tested in the order
C             specified.
C
C Modules required by ADDNOD:  BDYADD, CRTRI, INDXCC,
C                                INSERT, INTADD, JRAND,
C                                LEFT, LSTPTR, SWAP,
C                                SWPTST, TRFIND
C
C Intrinsic function called by ADDNOD:  ABS
C
C***********************************************************
C
      INTEGER INDXCC, LSTPTR
      INTEGER I, I1, I2, I3, IBK, IO1, IO2, IN1, KK, L,
     .        LCCIP1, LP, LPF, LPO1, NM1
      LOGICAL CRTRI, SWPTST
      KK = K
C
C Test for an invalid input parameter.
C
      IF (KK .LT. 1  .OR.  IST .LT. 1  .OR.  IST .GT. N
     .    .OR.  NCC .LT. 0  .OR.  N .LT. 3) GO TO 7
      LCCIP1 = N+1
      DO 1 I = NCC,1,-1
        IF (LCCIP1-LCC(I) .LT. 3) GO TO 7
        LCCIP1 = LCC(I)
    1   CONTINUE
      IF (KK .GT. LCCIP1) GO TO 7
C
C Find a triangle (I1,I2,I3) containing K or the rightmost
C   (I1) and leftmost (I2) visible boundary nodes as viewed
C   from node K.
C
      CALL TRFIND (IST,XK,YK,N,X,Y,LIST,LPTR,LEND, I1,I2,I3)
C
C Test for collinear nodes, duplicate nodes, and K lying in
C   a constraint region.
C
      IF (I1 .EQ. 0) GO TO 8
      IF (I3 .NE. 0) THEN
        L = I1
        IF (XK .EQ. X(L)  .AND.  YK .EQ. Y(L)) GO TO 9
        L = I2
        IF (XK .EQ. X(L)  .AND.  YK .EQ. Y(L)) GO TO 9
        L = I3
        IF (XK .EQ. X(L)  .AND.  YK .EQ. Y(L)) GO TO 9
        IF (NCC .GT. 0  .AND.  CRTRI(NCC,LCC,I1,I2,I3) )
     .    GO TO 10
      ELSE
C
C   K is outside the convex hull of the nodes and lies in a
C     constraint region iff an exterior constraint curve is
C     present.
C
        IF (NCC .GT. 0  .AND.  INDXCC(NCC,LCC,N,LIST,LEND)
     .      .NE. 0) GO TO 10
      ENDIF
C
C No errors encountered.
C
      IER = 0
      NM1 = N
      N = N + 1
      IF (KK .LT. N) THEN
C
C Open a slot for K in X, Y, and LEND, and increment all
C   nodal indexes which are greater than or equal to K.
C   Note that LIST, LPTR, and LNEW are not yet updated with
C   either the neighbors of K or the edges terminating on K.
C
        DO 2 IBK = NM1,KK,-1
          X(IBK+1) = X(IBK)
          Y(IBK+1) = Y(IBK)
          LEND(IBK+1) = LEND(IBK)
    2     CONTINUE
        DO 3 I = 1,NCC
          LCC(I) = LCC(I) + 1
    3     CONTINUE
        L = LNEW - 1
        DO 4 I = 1,L
          IF (LIST(I) .GE. KK) LIST(I) = LIST(I) + 1
          IF (LIST(I) .LE. -KK) LIST(I) = LIST(I) - 1
    4     CONTINUE
        IF (I1 .GE. KK) I1 = I1 + 1
        IF (I2 .GE. KK) I2 = I2 + 1
        IF (I3 .GE. KK) I3 = I3 + 1
      ENDIF
C
C Insert K into X and Y, and update LIST, LPTR, LEND, and
C   LNEW with the arcs containing node K.
C
      X(KK) = XK
      Y(KK) = YK
      IF (I3 .EQ. 0) THEN
        CALL BDYADD (KK,I1,I2, LIST,LPTR,LEND,LNEW )
      ELSE
        CALL INTADD (KK,I1,I2,I3, LIST,LPTR,LEND,LNEW )
      ENDIF
C
C Initialize variables for optimization of the triangula-
C   tion.
C
      LP = LEND(KK)
      LPF = LPTR(LP)
      IO2 = LIST(LPF)
      LPO1 = LPTR(LPF)
      IO1 = ABS(LIST(LPO1))
C
C Begin loop:  find the node opposite K.
C
    5 LP = LSTPTR(LEND(IO1),IO2,LIST,LPTR)
        IF (LIST(LP) .LT. 0) GO TO 6
        LP = LPTR(LP)
        IN1 = ABS(LIST(LP))
        IF ( CRTRI(NCC,LCC,IO1,IO2,IN1) ) GO TO 6
C
C Swap test:  if a swap occurs, two new arcs are
C             opposite K and must be tested.
C
        IF ( .NOT. SWPTST(IN1,KK,IO1,IO2,X,Y) ) GO TO 6
        CALL SWAP (IN1,KK,IO1,IO2, LIST,LPTR,LEND, LPO1)
        IF (LPO1 .EQ. 0) GO TO 11
        IO1 = IN1
        GO TO 5
C
C No swap occurred.  Test for termination and reset
C   IO2 and IO1.
C
    6   IF (LPO1 .EQ. LPF  .OR.  LIST(LPO1) .LT. 0) RETURN
        IO2 = IO1
        LPO1 = LPTR(LPO1)
        IO1 = ABS(LIST(LPO1))
        GO TO 5
C
C A parameter is outside its valid range on input.
C
    7 IER = -1
      RETURN
C
C All nodes are collinear.
C
    8 IER = -2
      RETURN
C
C Nodes L and K coincide.
C
    9 IER = L
      RETURN
C
C Node K lies in a constraint region.
C
   10 IER = -3
      RETURN
C
C Zero pointer returned by SWAP.
C
   11 IER = -4
      RETURN
      END
      DOUBLE PRECISION FUNCTION AREAP (X,Y,NB,NODES)
      INTEGER NB, NODES(NB)
      DOUBLE PRECISION X(*), Y(*)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/21/90
C
C   Given a sequence of NB points in the plane, this func-
C tion computes the signed area bounded by the closed poly-
C gonal curve which passes through the points in the
C specified order.  Each simple closed curve is positively
C oriented (bounds positive area) if and only if the points
C are specified in counterclockwise order.  The last point
C of the curve is taken to be the first point specified, and
C this point should therefore not be specified twice.
C
C   The area of a triangulation may be computed by calling
C AREAP with values of NB and NODES determined by Subroutine
C BNODES.
C
C
C On input:
C
C       X,Y = Arrays of length N containing the Cartesian
C             coordinates of a set of points in the plane
C             for some N .GE. NB.
C
C       NB = Length of NODES.
C
C       NODES = Array of length NB containing the ordered
C               sequence of nodal indexes (in the range
C               1 to N) which define the polygonal curve.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       AREAP = Signed area bounded by the polygonal curve,
C              or zero if NB < 3.
C
C Modules required by AREAP:  None
C
C***********************************************************
C
      INTEGER I, ND1, ND2, NNB
      DOUBLE PRECISION A
C
C Local parameters:
C
C A =       Partial sum of signed (and doubled) trapezoid
C             areas
C I =       DO-loop and NODES index
C ND1,ND2 = Elements of NODES
C NNB =     Local copy of NB
C
      NNB = NB
      A = 0.
      IF (NNB .LT. 3) GO TO 2
      ND2 = NODES(NNB)
C
C Loop on line segments NODES(I-1) -> NODES(I), where
C   NODES(0) = NODES(NB), adding twice the signed trapezoid
C   areas (integrals of the linear interpolants) to A.
C
      DO 1 I = 1,NNB
        ND1 = ND2
        ND2 = NODES(I)
        A = A + (X(ND2)-X(ND1))*(Y(ND1)+Y(ND2))
    1   CONTINUE
C
C A contains twice the negative signed area of the region.
C
    2 AREAP = -A/2.
      RETURN
      END
      SUBROUTINE BDYADD (KK,I1,I2, LIST,LPTR,LEND,LNEW )
      INTEGER KK, I1, I2, LIST(*), LPTR(*), LEND(*), LNEW
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   02/22/91
C
C   This subroutine adds a boundary node to a triangulation
C of a set of points in the plane.  The data structure is
C updated with the insertion of node KK, but no optimization
C is performed.
C
C
C On input:
C
C       KK = Index of a node to be connected to the sequence
C            of all visible boundary nodes.  KK .GE. 1 and
C            KK must not be equal to I1 or I2.
C
C       I1 = First (rightmost as viewed from KK) boundary
C            node in the triangulation which is visible from
C            node KK (the line segment KK-I1 intersects no
C            arcs.
C
C       I2 = Last (leftmost) boundary node which is visible
C            from node KK.  I1 and I2 may be determined by
C            Subroutine TRFIND.
C
C The above parameters are not altered by this routine.
C
C       LIST,LPTR,LEND,LNEW = Triangulation data structure
C                             created by TRMESH or TRMSHR.
C                             Nodes I1 and I2 must be in-
C                             cluded in the triangulation.
C
C On output:
C
C       LIST,LPTR,LEND,LNEW = Data structure updated with
C                             the addition of node KK.  Node
C                             KK is connected to I1, I2, and
C                             all boundary nodes in between.
C
C Module required by BDYADD:  INSERT
C
C***********************************************************
C
      INTEGER K, LP, LSAV, N1, N2, NEXT, NSAV
      K = KK
      N1 = I1
      N2 = I2
C
C Add K as the last neighbor of N1.
C
      LP = LEND(N1)
      LSAV = LPTR(LP)
      LPTR(LP) = LNEW
      LIST(LNEW) = -K
      LPTR(LNEW) = LSAV
      LEND(N1) = LNEW
      LNEW = LNEW + 1
      NEXT = -LIST(LP)
      LIST(LP) = NEXT
      NSAV = NEXT
C
C Loop on the remaining boundary nodes between N1 and N2,
C   adding K as the first neighbor.
C
    1 LP = LEND(NEXT)
        CALL INSERT (K,LP,LIST,LPTR,LNEW)
        IF (NEXT .EQ. N2) GO TO 2
        NEXT = -LIST(LP)
        LIST(LP) = NEXT
        GO TO 1
C
C Add the boundary nodes between N1 and N2 as neighbors
C   of node K.
C
    2 LSAV = LNEW
      LIST(LNEW) = N1
      LPTR(LNEW) = LNEW + 1
      LNEW = LNEW + 1
      NEXT = NSAV
C
    3 IF (NEXT .EQ. N2) GO TO 4
        LIST(LNEW) = NEXT
        LPTR(LNEW) = LNEW + 1
        LNEW = LNEW + 1
        LP = LEND(NEXT)
        NEXT = LIST(LP)
        GO TO 3
C
    4 LIST(LNEW) = -N2
      LPTR(LNEW) = LSAV
      LEND(K) = LNEW
      LNEW = LNEW + 1
      RETURN
      END
      SUBROUTINE BNODES (N,LIST,LPTR,LEND, NODES,NB,NA,NT)
      INTEGER N, LIST(*), LPTR(*), LEND(N), NODES(*), NB,
     .        NA, NT
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C   Given a triangulation of N points in the plane, this
C subroutine returns an array containing the indexes, in
C counterclockwise order, of the nodes on the boundary of
C the convex hull of the set of points.
C
C
C On input:
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C The above parameters are not altered by this routine.
C
C       NODES = Integer array of length at least NB
C               (NB .LE. N).
C
C On output:
C
C       NODES = Ordered sequence of boundary node indexes
C               in the range 1 to N.
C
C       NB = Number of boundary nodes.
C
C       NA,NT = Number of arcs and triangles, respectively,
C               in the triangulation.
C
C Modules required by BNODES:  None
C
C***********************************************************
C
      INTEGER K, LP, N0, NST
C
C Set NST to the first boundary node encountered.
C
      NST = 1
    1 LP = LEND(NST)
        IF (LIST(LP) .LT. 0) GO TO 2
        NST = NST + 1
        GO TO 1
C
C Initialization.
C
    2 NODES(1) = NST
      K = 1
      N0 = NST
C
C Traverse the boundary in counterclockwise order.
C
    3 LP = LEND(N0)
        LP = LPTR(LP)
        N0 = LIST(LP)
        IF (N0 .EQ. NST) GO TO 4
        K = K + 1
        NODES(K) = N0
        GO TO 3
C
C Termination.
C
    4 NB = K
      NT = 2*N - NB - 2
      NA = NT + N - 1
      RETURN
      END
      SUBROUTINE CIRCUM (X1,Y1,X2,Y2,X3,Y3,RATIO, XC,YC,CR,
     .                   SA,AR)
      LOGICAL RATIO
      DOUBLE PRECISION X1, Y1, X2, Y2, X3, Y3, XC, YC, CR,
     .           SA, AR
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   12/10/96
C
C   Given three vertices defining a triangle, this subrou-
C tine returns the circumcenter, circumradius, signed
C triangle area, and, optionally, the aspect ratio of the
C triangle.
C
C
C On input:
C
C       X1,...,Y3 = Cartesian coordinates of the vertices.
C
C       RATIO = Logical variable with value TRUE if and only
C               if the aspect ratio is to be computed.
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       XC,YC = Cartesian coordinates of the circumcenter
C               (center of the circle defined by the three
C               points) unless SA = 0, in which XC and YC
C               are not altered.
C
C       CR = Circumradius (radius of the circle defined by
C            the three points) unless SA = 0 (infinite
C            radius), in which case CR is not altered.
C
C       SA = Signed triangle area with positive value if
C            and only if the vertices are specified in
C            counterclockwise order:  (X3,Y3) is strictly
C            to the left of the directed line from (X1,Y1)
C            toward (X2,Y2).
C
C       AR = Aspect ratio r/CR, where r is the radius of the
C            inscribed circle, unless RATIO = FALSE, in
C            which case AR is not altered.  AR is in the
C            range 0 to .5, with value 0 iff SA = 0 and
C            value .5 iff the vertices define an equilateral
C            triangle.
C
C Modules required by CIRCUM:  None
C
C Intrinsic functions called by CIRCUM:  ABS, SQRT
C
C***********************************************************
C
      INTEGER I
      DOUBLE PRECISION DS(3), FX, FY, U(3), V(3)
C
C Set U(K) and V(K) to the x and y components, respectively,
C   of the directed edge opposite vertex K.
C
      U(1) = X3 - X2
      U(2) = X1 - X3
      U(3) = X2 - X1
      V(1) = Y3 - Y2
      V(2) = Y1 - Y3
      V(3) = Y2 - Y1
C
C Set SA to the signed triangle area.
C
      SA = (U(1)*V(2) - U(2)*V(1))/2.
      IF (SA .EQ. 0.) THEN
        IF (RATIO) AR = 0.
        RETURN
      ENDIF
C
C Set DS(K) to the squared distance from the origin to
C   vertex K.
C
      DS(1) = X1*X1 + Y1*Y1
      DS(2) = X2*X2 + Y2*Y2
      DS(3) = X3*X3 + Y3*Y3
C
C Compute factors of XC and YC.
C
      FX = 0.
      FY = 0.
      DO 1 I = 1,3
        FX = FX - DS(I)*V(I)
        FY = FY + DS(I)*U(I)
    1   CONTINUE
      XC = FX/(4.*SA)
      YC = FY/(4.*SA)
      CR = SQRT( (XC-X1)**2 + (YC-Y1)**2 )
      IF (.NOT. RATIO) RETURN
C
C Compute the squared edge lengths and aspect ratio.
C
      DO 2 I = 1,3
        DS(I) = U(I)*U(I) + V(I)*V(I)
    2   CONTINUE
      AR = 2.*ABS(SA)/
     .     ( (SQRT(DS(1)) + SQRT(DS(2)) + SQRT(DS(3)))*CR )
      RETURN
      END
      LOGICAL FUNCTION CRTRI (NCC,LCC,I1,I2,I3)
      INTEGER NCC, LCC(*), I1, I2, I3
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   08/14/91
C
C   This function returns TRUE if and only if triangle (I1,
C I2,I3) lies in a constraint region.
C
C
C On input:
C
C       NCC,LCC = Constraint data structure.  Refer to Sub-
C                 routine ADDCST.
C
C       I1,I2,I3 = Nodal indexes of the counterclockwise-
C                  ordered vertices of a triangle.
C
C Input parameters are altered by this function.
C
C       CRTRI = TRUE iff (I1,I2,I3) is a constraint region
C               triangle.
C
C Note that input parameters are not tested for validity.
C
C Modules required by CRTRI:  None
C
C Intrinsic functions called by CRTRI:  MAX, MIN
C
C***********************************************************
C
      INTEGER I, IMAX, IMIN
      IMAX = MAX(I1,I2,I3)
C
C   Find the index I of the constraint containing IMAX.
C
      I = NCC + 1
    1 I = I - 1
        IF (I .LE. 0) GO TO 2
        IF (IMAX .LT. LCC(I)) GO TO 1
      IMIN = MIN(I1,I2,I3)
C
C P lies in a constraint region iff I1, I2, and I3 are nodes
C   of the same constraint (IMIN >= LCC(I)), and (IMIN,IMAX)
C   is (I1,I3), (I2,I1), or (I3,I2).
C
      CRTRI = IMIN .GE. LCC(I)  .AND.  ((IMIN .EQ. I1 .AND.
     .        IMAX .EQ. I3)  .OR.  (IMIN .EQ. I2  .AND.
     .        IMAX .EQ. I1)  .OR.  (IMIN .EQ. I3  .AND.
     .        IMAX .EQ. I2))
      RETURN
C
C NCC .LE. 0 or all vertices are non-constraint nodes.
C
    2 CRTRI = .FALSE.
      RETURN
      END
      SUBROUTINE DELARC (N,IO1,IO2, LIST,LPTR,LEND,
     .                   LNEW, IER)
      INTEGER N, IO1, IO2, LIST(*), LPTR(*), LEND(N), LNEW,
     .        IER
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   11/12/94
C
C   This subroutine deletes a boundary arc from a triangula-
C tion.  It may be used to remove a null triangle from the
C convex hull boundary.  Note, however, that if the union of
C triangles is rendered nonconvex, Subroutines DELNOD, EDGE,
C and TRFIND may fail.  Thus, Subroutines ADDCST, ADDNOD,
C DELNOD, EDGE, and NEARND should not be called following
C an arc deletion.
C
C
C On input:
C
C       N = Number of nodes in the triangulation.  N .GE. 4.
C
C       IO1,IO2 = Indexes (in the range 1 to N) of a pair of
C                 adjacent boundary nodes defining the arc
C                 to be removed.
C
C The above parameters are not altered by this routine.
C
C       LIST,LPTR,LEND,LNEW = Triangulation data structure
C                             created by TRMESH or TRMSHR.
C
C On output:
C
C       LIST,LPTR,LEND,LNEW = Data structure updated with
C                             the removal of arc IO1-IO2
C                             unless IER > 0.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if N, IO1, or IO2 is outside its valid
C                     range, or IO1 = IO2.
C             IER = 2 if IO1-IO2 is not a boundary arc.
C             IER = 3 if the node opposite IO1-IO2 is al-
C                     ready a boundary node, and thus IO1
C                     or IO2 has only two neighbors or a
C                     deletion would result in two triangu-
C                     lations sharing a single node.
C             IER = 4 if one of the nodes is a neighbor of
C                     the other, but not vice versa, imply-
C                     ing an invalid triangulation data
C                     structure.
C
C Modules required by DELARC:  DELNB, LSTPTR
C
C Intrinsic function called by DELARC:  ABS
C
C***********************************************************
C
      INTEGER LSTPTR
      INTEGER LP, LPH, LPL, N1, N2, N3
      N1 = IO1
      N2 = IO2
C
C Test for errors, and set N1->N2 to the directed boundary
C   edge associated with IO1-IO2:  (N1,N2,N3) is a triangle
C   for some N3.
C
      IF (N .LT. 4  .OR.  N1 .LT. 1  .OR.  N1 .GT. N  .OR.
     .    N2 .LT. 1  .OR.  N2 .GT. N  .OR.  N1 .EQ. N2) THEN
        IER = 1
        RETURN
      ENDIF
C
      LPL = LEND(N2)
      IF (-LIST(LPL) .NE. N1) THEN
        N1 = N2
        N2 = IO1
        LPL = LEND(N2)
        IF (-LIST(LPL) .NE. N1) THEN
          IER = 2
          RETURN
        ENDIF
      ENDIF
C
C Set N3 to the node opposite N1->N2 (the second neighbor
C   of N1), and test for error 3 (N3 already a boundary
C   node).
C
      LPL = LEND(N1)
      LP = LPTR(LPL)
      LP = LPTR(LP)
      N3 = ABS(LIST(LP))
      LPL = LEND(N3)
      IF (LIST(LPL) .LE. 0) THEN
        IER = 3
        RETURN
      ENDIF
C
C Delete N2 as a neighbor of N1, making N3 the first
C   neighbor, and test for error 4 (N2 not a neighbor
C   of N1).  Note that previously computed pointers may
C   no longer be valid following the call to DELNB.
C
      CALL DELNB (N1,N2,N, LIST,LPTR,LEND,LNEW, LPH)
      IF (LPH .LT. 0) THEN
        IER = 4
        RETURN
      ENDIF
C
C Delete N1 as a neighbor of N2, making N3 the new last
C   neighbor.
C
      CALL DELNB (N2,N1,N, LIST,LPTR,LEND,LNEW, LPH)
C
C Make N3 a boundary node with first neighbor N2 and last
C   neighbor N1.
C
      LP = LSTPTR(LEND(N3),N1,LIST,LPTR)
      LEND(N3) = LP
      LIST(LP) = -N1
C
C No errors encountered.
C
      IER = 0
      RETURN
      END
      SUBROUTINE DELNB (N0,NB,N, LIST,LPTR,LEND,LNEW, LPH)
      INTEGER N0, NB, N, LIST(*), LPTR(*), LEND(N), LNEW,
     .        LPH
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/30/98
C
C   This subroutine deletes a neighbor NB from the adjacency
C list of node N0 (but N0 is not deleted from the adjacency
C list of NB) and, if NB is a boundary node, makes N0 a
C boundary node.  For pointer (LIST index) LPH to NB as a
C neighbor of N0, the empty LIST,LPTR location LPH is filled
C in with the values at LNEW-1, pointer LNEW-1 (in LPTR and
C possibly in LEND) is changed to LPH, and LNEW is decremen-
C ted.  This requires a search of LEND and LPTR entailing an
C expected operation count of O(N).
C
C
C On input:
C
C       N0,NB = Indexes, in the range 1 to N, of a pair of
C               nodes such that NB is a neighbor of N0.
C               (N0 need not be a neighbor of NB.)
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C The above parameters are not altered by this routine.
C
C       LIST,LPTR,LEND,LNEW = Data structure defining the
C                             triangulation.
C
C On output:
C
C       LIST,LPTR,LEND,LNEW = Data structure updated with
C                             the removal of NB from the ad-
C                             jacency list of N0 unless
C                             LPH < 0.
C
C       LPH = List pointer to the hole (NB as a neighbor of
C             N0) filled in by the values at LNEW-1 or error
C             indicator:
C             LPH > 0 if no errors were encountered.
C             LPH = -1 if N0, NB, or N is outside its valid
C                      range.
C             LPH = -2 if NB is not a neighbor of N0.
C
C Modules required by DELNB:  None
C
C Intrinsic function called by DELNB:  ABS
C
C***********************************************************
C
      INTEGER I, LNW, LP, LPB, LPL, LPP, NN
C
C Local parameters:
C
C I =   DO-loop index
C LNW = LNEW-1 (output value of LNEW)
C LP =  LIST pointer of the last neighbor of NB
C LPB = Pointer to NB as a neighbor of N0
C LPL = Pointer to the last neighbor of N0
C LPP = Pointer to the neighbor of N0 that precedes NB
C NN =  Local copy of N
C
      NN = N
C
C Test for error 1.
C
      IF (N0 .LT. 1  .OR.  N0 .GT. NN  .OR.  NB .LT. 1  .OR.
     .    NB .GT. NN  .OR.  NN .LT. 3) THEN
        LPH = -1
        RETURN
      ENDIF
C
C   Find pointers to neighbors of N0:
C
C     LPL points to the last neighbor,
C     LPP points to the neighbor NP preceding NB, and
C     LPB points to NB.
C
      LPL = LEND(N0)
      LPP = LPL
      LPB = LPTR(LPP)
    1 IF (LIST(LPB) .EQ. NB) GO TO 2
        LPP = LPB
        LPB = LPTR(LPP)
        IF (LPB .NE. LPL) GO TO 1
C
C   Test for error 2 (NB not found).
C
      IF (ABS(LIST(LPB)) .NE. NB) THEN
        LPH = -2
        RETURN
      ENDIF
C
C   NB is the last neighbor of N0.  Make NP the new last
C     neighbor and, if NB is a boundary node, then make N0
C     a boundary node.
C
      LEND(N0) = LPP
      LP = LEND(NB)
      IF (LIST(LP) .LT. 0) LIST(LPP) = -LIST(LPP)
      GO TO 3
C
C   NB is not the last neighbor of N0.  If NB is a boundary
C     node and N0 is not, then make N0 a boundary node with
C     last neighbor NP.
C
    2 LP = LEND(NB)
      IF (LIST(LP) .LT. 0  .AND.  LIST(LPL) .GT. 0) THEN
        LEND(N0) = LPP
        LIST(LPP) = -LIST(LPP)
      ENDIF
C
C   Update LPTR so that the neighbor following NB now fol-
C     lows NP, and fill in the hole at location LPB.
C
    3 LPTR(LPP) = LPTR(LPB)
      LNW = LNEW-1
      LIST(LPB) = LIST(LNW)
      LPTR(LPB) = LPTR(LNW)
      DO 4 I = NN,1,-1
        IF (LEND(I) .EQ. LNW) THEN
          LEND(I) = LPB
          GO TO 5
        ENDIF
    4   CONTINUE
C
    5 DO 6 I = 1,LNW-1
        IF (LPTR(I) .EQ. LNW) THEN
          LPTR(I) = LPB
        ENDIF
    6   CONTINUE
C
C No errors encountered.
C
      LNEW = LNW
      LPH = LPB
      RETURN
      END
      SUBROUTINE DELNOD (K,NCC, LCC,N,X,Y,LIST,LPTR,LEND,
     .                   LNEW,LWK,IWK, IER)
      INTEGER K, NCC, LCC(*), N, LIST(*), LPTR(*),
     .        LEND(*), LNEW, LWK, IWK(2,*), IER
      DOUBLE PRECISION X(*), Y(*)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/28/98
C
C   This subroutine deletes node K (along with all arcs
C incident on node K) from a triangulation of N nodes in the
C plane, and inserts arcs as necessary to produce a triangu-
C lation of the remaining N-1 nodes.  If a Delaunay triangu-
C lation is input, a Delaunay triangulation will result, and
C thus, DELNOD reverses the effect of a call to Subroutine
C ADDNOD.
C
C   Note that a constraint node cannot be deleted by this
C routine.  In order to delete a constraint node, it is
C necessary to call this routine with NCC = 0, decrement the
C appropriate LCC entries (LCC(I) such that LCC(I) > K), and
C then create (or restore) the constraints by a call to Sub-
C routine ADDCST.
C
C
C On input:
C
C       K = Index (for X and Y) of the node to be deleted.
C           1 .LE. K .LT. LCC(1).  (K .LE. N if NCC=0).
C
C       NCC = Number of constraint curves.  NCC .GE. 0.
C
C The above parameters are not altered by this routine.
C
C       LCC = List of constraint curve starting indexes (or
C             dummy array of length 1 if NCC = 0).  Refer to
C             Subroutine ADDCST.
C
C       N = Number of nodes in the triangulation on input.
C           N .GE. 4.  Note that N will be decremented
C           following the deletion.
C
C       X,Y = Arrays of length N containing the coordinates
C             of the nodes with non-constraint nodes in the
C             first LCC(1)-1 locations if NCC > 0.
C
C       LIST,LPTR,LEND,LNEW = Data structure defining the
C                             triangulation.  Refer to Sub-
C                             routine TRMESH.
C
C       LWK = Number of columns reserved for IWK.  LWK must
C             be at least NNB-3, where NNB is the number of
C             neighbors of node K, including an extra
C             pseudo-node if K is a boundary node.
C
C       IWK = Integer work array dimensioned 2 by LWK (or
C             array of length .GE. 2*LWK).
C
C On output:
C
C       LCC = List of constraint curve starting indexes de-
C             cremented by 1 to reflect the deletion of K
C             unless NCC = 0 or 1 .LE. IER .LE. 4.
C
C       N = New number of nodes (input value minus one) un-
C           less 1 .LE. IER .LE. 4.
C
C       X,Y = Updated arrays of length N-1 containing nodal
C             coordinates (with elements K+1,...,N shifted
C             up a position and thus overwriting element K)
C             unless 1 .LE. IER .LE. 4.  (N here denotes the
C             input value.)
C
C       LIST,LPTR,LEND,LNEW = Updated triangulation data
C                             structure reflecting the dele-
C                             tion unless IER .NE. 0.  Note
C                             that the data structure may
C                             have been altered if IER .GE.
C                             3.
C
C       LWK = Number of IWK columns required unless IER = 1
C             or IER = 3.
C
C       IWK = Indexes of the endpoints of the new arcs added
C             unless LWK = 0 or 1 .LE. IER .LE. 4.  (Arcs
C             are associated with columns, or pairs of
C             adjacent elements if IWK is declared as a
C             singly-subscripted array.)
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if K, NCC, N, or an LCC entry is out-
C                     side its valid range or LWK < 0 on
C                     input.
C             IER = 2 if more space is required in IWK.
C                     Refer to LWK.
C             IER = 3 if the triangulation data structure is
C                     invalid on input.
C             IER = 4 if K is an interior node with 4 or
C                     more neighbors, and the number of
C                     neighbors could not be reduced to 3
C                     by swaps.  This could be caused by
C                     floating point errors with collinear
C                     nodes or by an invalid data structure.
C             IER = 5 if an error flag was returned by
C                     OPTIM.  An error message is written
C                     to the standard output unit in this
C                     event.
C
C   Note that the deletion may result in all remaining nodes
C being collinear.  This situation is not flagged.
C
C Modules required by DELNOD:  DELNB, LEFT, LSTPTR, NBCNT,
C                                OPTIM, SWAP, SWPTST
C
C Intrinsic function called by DELNOD:  ABS
C
C***********************************************************
C
      INTEGER LSTPTR, NBCNT
      LOGICAL LEFT
      INTEGER I, IERR, IWL, J, LCCIP1, LNW, LP, LP21, LPF,
     .        LPH, LPL, LPL2, LPN, LWKL, N1, N2, NFRST, NIT,
     .        NL, NN, NNB, NR
      LOGICAL BDRY
      DOUBLE PRECISION X1, X2, XL, XR, Y1, Y2, YL, YR
C
C Set N1 to K and NNB to the number of neighbors of N1 (plus
C   one if N1 is a boundary node), and test for errors.  LPF
C   and LPL are LIST indexes of the first and last neighbors
C   of N1, IWL is the number of IWK columns containing arcs,
C   and BDRY is TRUE iff N1 is a boundary node.
C
      N1 = K
      NN = N
      IF (NCC .LT. 0  .OR.  N1 .LT. 1  .OR.  NN .LT. 4  .OR.
     .    LWK .LT. 0) GO TO 21
      LCCIP1 = NN+1
      DO 1 I = NCC,1,-1
        IF (LCCIP1-LCC(I) .LT. 3) GO TO 21
        LCCIP1 = LCC(I)
    1   CONTINUE
      IF (N1 .GE. LCCIP1) GO TO 21
      LPL = LEND(N1)
      LPF = LPTR(LPL)
      NNB = NBCNT(LPL,LPTR)
      BDRY = LIST(LPL) .LT. 0
      IF (BDRY) NNB = NNB + 1
      IF (NNB .LT. 3) GO TO 23
      LWKL = LWK
      LWK = NNB - 3
      IF (LWKL .LT. LWK) GO TO 22
      IWL = 0
      IF (NNB .EQ. 3) GO TO 5
C
C Initialize for loop on arcs N1-N2 for neighbors N2 of N1,
C   beginning with the second neighbor.  NR and NL are the
C   neighbors preceding and following N2, respectively, and
C   LP indexes NL.  The loop is exited when all possible
C   swaps have been applied to arcs incident on N1.  If N1
C   is interior, the number of neighbors will be reduced
C   to 3.
C
      X1 = X(N1)
      Y1 = Y(N1)
      NFRST = LIST(LPF)
      NR = NFRST
      XR = X(NR)
      YR = Y(NR)
      LP = LPTR(LPF)
      N2 = LIST(LP)
      X2 = X(N2)
      Y2 = Y(N2)
      LP = LPTR(LP)
C
C Top of loop:  set NL to the neighbor following N2.
C
    2 NL = ABS(LIST(LP))
      IF (NL .EQ. NFRST  .AND.  BDRY) GO TO 5
      XL = X(NL)
      YL = Y(NL)
C
C   Test for a convex quadrilateral.  To avoid an incorrect
C     test caused by collinearity, use the fact that if N1
C     is a boundary node, then N1 LEFT NR->NL and if N2 is
C     a boundary node, then N2 LEFT NL->NR.
C
      LPL2 = LEND(N2)
      IF ( (BDRY  .OR.  LEFT(XR,YR,XL,YL,X1,Y1))  .AND.
     .     (LIST(LPL2) .LT. 0  .OR.
     .      LEFT(XL,YL,XR,YR,X2,Y2)) ) GO TO 3
C
C   Nonconvex quadrilateral -- no swap is possible.
C
      NR = N2
      XR = X2
      YR = Y2
      GO TO 4
C
C   The quadrilateral defined by adjacent triangles
C     (N1,N2,NL) and (N2,N1,NR) is convex.  Swap in
C     NL-NR and store it in IWK.  Indexes larger than N1
C     must be decremented since N1 will be deleted from
C     X and Y.
C
    3 CALL SWAP (NL,NR,N1,N2, LIST,LPTR,LEND, LP21)
      IWL = IWL + 1
      IF (NL .LE. N1) THEN
        IWK(1,IWL) = NL
      ELSE
        IWK(1,IWL) = NL - 1
      ENDIF
      IF (NR .LE. N1) THEN
        IWK(2,IWL) = NR
      ELSE
        IWK(2,IWL) = NR - 1
      ENDIF
C
C   Recompute the LIST indexes LPL,LP and decrement NNB.
C
      LPL = LEND(N1)
      NNB = NNB - 1
      IF (NNB .EQ. 3) GO TO 5
      LP = LSTPTR(LPL,NL,LIST,LPTR)
      IF (NR .EQ. NFRST) GO TO 4
C
C   NR is not the first neighbor of N1.
C     Back up and test N1-NR for a swap again:  Set N2 to
C     NR and NR to the previous neighbor of N1 -- the
C     neighbor of NR which follows N1.  LP21 points to NL
C     as a neighbor of NR.
C
      N2 = NR
      X2 = XR
      Y2 = YR
      LP21 = LPTR(LP21)
      LP21 = LPTR(LP21)
      NR = ABS(LIST(LP21))
      XR = X(NR)
      YR = Y(NR)
      GO TO 2
C
C   Bottom of loop -- test for invalid termination.
C
    4 IF (N2 .EQ. NFRST) GO TO 24
      N2 = NL
      X2 = XL
      Y2 = YL
      LP = LPTR(LP)
      GO TO 2
C
C Delete N1 from the adjacency list of N2 for all neighbors
C   N2 of N1.  LPL points to the last neighbor of N1.
C   LNEW is stored in local variable LNW.
C
    5 LP = LPL
      LNW = LNEW
C
C Loop on neighbors N2 of N1, beginning with the first.
C
    6 LP = LPTR(LP)
        N2 = ABS(LIST(LP))
        CALL DELNB (N2,N1,N, LIST,LPTR,LEND,LNW, LPH)
        IF (LPH .LT. 0) GO TO 23
C
C   LP and LPL may require alteration.
C
        IF (LPL .EQ. LNW) LPL = LPH
        IF (LP .EQ. LNW) LP = LPH
        IF (LP .NE. LPL) GO TO 6
C
C Delete N1 from X, Y, and LEND, and remove its adjacency
C   list from LIST and LPTR.  LIST entries (nodal indexes)
C   which are larger than N1 must be decremented.
C
      NN = NN - 1
      IF (N1 .GT. NN) GO TO 9
      DO 7 I = N1,NN
        X(I) = X(I+1)
        Y(I) = Y(I+1)
        LEND(I) = LEND(I+1)
    7   CONTINUE
C
      DO 8 I = 1,LNW-1
        IF (LIST(I) .GT. N1) LIST(I) = LIST(I) - 1
        IF (LIST(I) .LT. -N1) LIST(I) = LIST(I) + 1
    8   CONTINUE
C
C   For LPN = first to last neighbors of N1, delete the
C     preceding neighbor (indexed by LP).
C
C   Each empty LIST,LPTR location LP is filled in with the
C     values at LNW-1, and LNW is decremented.  All pointers
C     (including those in LPTR and LEND) with value LNW-1
C     must be changed to LP.
C
C  LPL points to the last neighbor of N1.
C
    9 IF (BDRY) NNB = NNB - 1
      LPN = LPL
      DO 13 J = 1,NNB
        LNW = LNW - 1
        LP = LPN
        LPN = LPTR(LP)
        LIST(LP) = LIST(LNW)
        LPTR(LP) = LPTR(LNW)
        IF (LPTR(LPN) .EQ. LNW) LPTR(LPN) = LP
        IF (LPN .EQ. LNW) LPN = LP
        DO 10 I = NN,1,-1
          IF (LEND(I) .EQ. LNW) THEN
            LEND(I) = LP
            GO TO 11
          ENDIF
   10     CONTINUE
C
   11   DO 12 I = LNW-1,1,-1
          IF (LPTR(I) .EQ. LNW) LPTR(I) = LP
   12     CONTINUE
   13   CONTINUE
C
C Decrement LCC entries.
C
      DO 14 I = 1,NCC
        LCC(I) = LCC(I) - 1
   14   CONTINUE
C
C Update N and LNEW, and optimize the patch of triangles
C   containing K (on input) by applying swaps to the arcs
C   in IWK.
C
      N = NN
      LNEW = LNW
      IF (IWL .GT. 0) THEN
        NIT = 4*IWL
        CALL OPTIM (X,Y,IWL, LIST,LPTR,LEND,NIT,IWK, IERR)
        IF (IERR .NE. 0) GO TO 25
      ENDIF
C
C Successful termination.
C
      IER = 0
      RETURN
C
C Invalid input parameter.
C
   21 IER = 1
      RETURN
C
C Insufficient space reserved for IWK.
C
   22 IER = 2
      RETURN
C
C Invalid triangulation data structure.  NNB < 3 on input or
C   N2 is a neighbor of N1 but N1 is not a neighbor of N2.
C
   23 IER = 3
      RETURN
C
C K is an interior node with 4 or more neighbors, but the
C   number of neighbors could not be reduced.
C
   24 IER = 4
      RETURN
C
C Error flag returned by OPTIM.
C
   25 IER = 5
      WRITE (*,100) NIT, IERR
      RETURN
  100 FORMAT (//5X,'*** Error in OPTIM:  NIT = ',I4,
     .        ', IER = ',I1,' ***'/)
      END
      SUBROUTINE EDGE (IN1,IN2,X,Y, LWK,IWK,LIST,LPTR,
     .                 LEND, IER)
      INTEGER IN1, IN2, LWK, IWK(2,*), LIST(*), LPTR(*),
     .        LEND(*), IER
      DOUBLE PRECISION X(*), Y(*)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/23/98
C
C   Given a triangulation of N nodes and a pair of nodal
C indexes IN1 and IN2, this routine swaps arcs as necessary
C to force IN1 and IN2 to be adjacent.  Only arcs which
C intersect IN1-IN2 are swapped out.  If a Delaunay triangu-
C lation is input, the resulting triangulation is as close
C as possible to a Delaunay triangulation in the sense that
C all arcs other than IN1-IN2 are locally optimal.
C
C   A sequence of calls to EDGE may be used to force the
C presence of a set of edges defining the boundary of a non-
C convex and/or multiply connected region (refer to Subrou-
C tine ADDCST), or to introduce barriers into the triangula-
C tion.  Note that Subroutine GETNP will not necessarily
C return closest nodes if the triangulation has been con-
C strained by a call to EDGE.  However, this is appropriate
C in some applications, such as triangle-based interpolation
C on a nonconvex domain.
C
C
C On input:
C
C       IN1,IN2 = Indexes (of X and Y) in the range 1 to N
C                 defining a pair of nodes to be connected
C                 by an arc.
C
C       X,Y = Arrays of length N containing the Cartesian
C             coordinates of the nodes.
C
C The above parameters are not altered by this routine.
C
C       LWK = Number of columns reserved for IWK.  This must
C             be at least NI -- the number of arcs which
C             intersect IN1-IN2.  (NI is bounded by N-3.)
C
C       IWK = Integer work array of length at least 2*LWK.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C On output:
C
C       LWK = Number of arcs which intersect IN1-IN2 (but
C             not more than the input value of LWK) unless
C             IER = 1 or IER = 3.  LWK = 0 if and only if
C             IN1 and IN2 were adjacent (or LWK=0) on input.
C
C       IWK = Array containing the indexes of the endpoints
C             of the new arcs other than IN1-IN2 unless IER
C             .GT. 0 or LWK = 0.  New arcs to the left of
C             IN2-IN1 are stored in the first K-1 columns
C             (left portion of IWK), column K contains
C             zeros, and new arcs to the right of IN2-IN1
C             occupy columns K+1,...,LWK.  (K can be deter-
C             mined by searching IWK for the zeros.)
C
C       LIST,LPTR,LEND = Data structure updated if necessary
C                        to reflect the presence of an arc
C                        connecting IN1 and IN2 unless IER
C                        .NE. 0.  The data structure has
C                        been altered if IER = 4.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if IN1 .LT. 1, IN2 .LT. 1, IN1 = IN2,
C                     or LWK .LT. 0 on input.
C             IER = 2 if more space is required in IWK.
C             IER = 3 if IN1 and IN2 could not be connected
C                     due to either an invalid data struc-
C                     ture or collinear nodes (and floating
C                     point error).
C             IER = 4 if an error flag was returned by
C                     OPTIM.
C
C   An error message is written to the standard output unit
C in the case of IER = 3 or IER = 4.
C
C Modules required by EDGE:  LEFT, LSTPTR, OPTIM, SWAP,
C                              SWPTST
C
C Intrinsic function called by EDGE:  ABS
C
C***********************************************************
C
      LOGICAL LEFT
      INTEGER I, IERR, IWC, IWCP1, IWEND, IWF, IWL, LFT, LP,
     .        LPL, LP21, NEXT, NIT, NL, NR, N0, N1, N2,
     .        N1FRST, N1LST
      DOUBLE PRECISION DX, DY, X0, Y0, X1, Y1, X2, Y2
C
C Local parameters:
C
C DX,DY =   Components of arc N1-N2
C I =       DO-loop index and column index for IWK
C IERR =    Error flag returned by Subroutine OPTIM
C IWC =     IWK index between IWF and IWL -- NL->NR is
C             stored in IWK(1,IWC)->IWK(2,IWC)
C IWCP1 =   IWC + 1
C IWEND =   Input or output value of LWK
C IWF =     IWK (column) index of the first (leftmost) arc
C             which intersects IN1->IN2
C IWL =     IWK (column) index of the last (rightmost) are
C             which intersects IN1->IN2
C LFT =     Flag used to determine if a swap results in the
C             new arc intersecting IN1-IN2 -- LFT = 0 iff
C             N0 = IN1, LFT = -1 implies N0 LEFT IN1->IN2,
C             and LFT = 1 implies N0 LEFT IN2->IN1
C LP21 =    Unused parameter returned by SWAP
C LP =      List pointer (index) for LIST and LPTR
C LPL =     Pointer to the last neighbor of IN1 or NL
C N0 =      Neighbor of N1 or node opposite NR->NL
C N1,N2 =   Local copies of IN1 and IN2
C N1FRST =  First neighbor of IN1
C N1LST =   (Signed) last neighbor of IN1
C NEXT =    Node opposite NL->NR
C NIT =     Flag or number of iterations employed by OPTIM
C NL,NR =   Endpoints of an arc which intersects IN1-IN2
C             with NL LEFT IN1->IN2
C X0,Y0 =   Coordinates of N0
C X1,Y1 =   Coordinates of IN1
C X2,Y2 =   Coordinates of IN2
C
C
C Store IN1, IN2, and LWK in local variables and test for
C   errors.
C
      N1 = IN1
      N2 = IN2
      IWEND = LWK
      IF (N1 .LT. 1  .OR.  N2 .LT. 1  .OR.  N1 .EQ. N2  .OR.
     .    IWEND .LT. 0) GO TO 31
C
C Test for N2 as a neighbor of N1.  LPL points to the last
C   neighbor of N1.
C
      LPL = LEND(N1)
      N0 = ABS(LIST(LPL))
      LP = LPL
    1 IF (N0 .EQ. N2) GO TO 30
        LP = LPTR(LP)
        N0 = LIST(LP)
        IF (LP .NE. LPL) GO TO 1
C
C Initialize parameters.
C
      IWL = 0
      NIT = 0
C
C Store the coordinates of N1 and N2.
C
    2 X1 = X(N1)
      Y1 = Y(N1)
      X2 = X(N2)
      Y2 = Y(N2)
C
C Set NR and NL to adjacent neighbors of N1 such that
C   NR LEFT N2->N1 and NL LEFT N1->N2,
C   (NR Forward N1->N2 or NL Forward N1->N2), and
C   (NR Forward N2->N1 or NL Forward N2->N1).
C
C   Initialization:  Set N1FRST and N1LST to the first and
C     (signed) last neighbors of N1, respectively, and
C     initialize NL to N1FRST.
C
      LPL = LEND(N1)
      N1LST = LIST(LPL)
      LP = LPTR(LPL)
      N1FRST = LIST(LP)
      NL = N1FRST
      IF (N1LST .LT. 0) GO TO 4
C
C   N1 is an interior node.  Set NL to the first candidate
C     for NR (NL LEFT N2->N1).
C
    3 IF ( LEFT(X2,Y2,X1,Y1,X(NL),Y(NL)) ) GO TO 4
        LP = LPTR(LP)
        NL = LIST(LP)
        IF (NL .NE. N1FRST) GO TO 3
C
C   All neighbors of N1 are strictly left of N1->N2.
C
      GO TO 5
C
C   NL = LIST(LP) LEFT N2->N1.  Set NR to NL and NL to the
C     following neighbor of N1.
C
    4 NR = NL
        LP = LPTR(LP)
        NL = ABS(LIST(LP))
        IF ( LEFT(X1,Y1,X2,Y2,X(NL),Y(NL)) ) THEN
C
C   NL LEFT N1->N2 and NR LEFT N2->N1.  The Forward tests
C     are employed to avoid an error associated with
C     collinear nodes.
C
          DX = X2-X1
          DY = Y2-Y1
          IF ((DX*(X(NL)-X1)+DY*(Y(NL)-Y1) .GE. 0.  .OR.
     .         DX*(X(NR)-X1)+DY*(Y(NR)-Y1) .GE. 0.)  .AND.
     .        (DX*(X(NL)-X2)+DY*(Y(NL)-Y2) .LE. 0.  .OR.
     .         DX*(X(NR)-X2)+DY*(Y(NR)-Y2) .LE. 0.)) GO TO 6
C
C   NL-NR does not intersect N1-N2.  However, there is
C     another candidate for the first arc if NL lies on
C     the line N1-N2.
C
          IF ( .NOT. LEFT(X2,Y2,X1,Y1,X(NL),Y(NL)) ) GO TO 5
        ENDIF
C
C   Bottom of loop.
C
        IF (NL .NE. N1FRST) GO TO 4
C
C Either the triangulation is invalid or N1-N2 lies on the
C   convex hull boundary and an edge NR->NL (opposite N1 and
C   intersecting N1-N2) was not found due to floating point
C   error.  Try interchanging N1 and N2 -- NIT > 0 iff this
C   has already been done.
C
    5 IF (NIT .GT. 0) GO TO 33
      NIT = 1
      N1 = N2
      N2 = IN1
      GO TO 2
C
C Store the ordered sequence of intersecting edges NL->NR in
C   IWK(1,IWL)->IWK(2,IWL).
C
    6 IWL = IWL + 1
      IF (IWL .GT. IWEND) GO TO 32
      IWK(1,IWL) = NL
      IWK(2,IWL) = NR
C
C   Set NEXT to the neighbor of NL which follows NR.
C
      LPL = LEND(NL)
      LP = LPTR(LPL)
C
C   Find NR as a neighbor of NL.  The search begins with
C     the first neighbor.
C
    7 IF (LIST(LP) .EQ. NR) GO TO 8
        LP = LPTR(LP)
        IF (LP .NE. LPL) GO TO 7
C
C   NR must be the last neighbor, and NL->NR cannot be a
C     boundary edge.
C
      IF (LIST(LP) .NE. NR) GO TO 33
C
C   Set NEXT to the neighbor following NR, and test for
C     termination of the store loop.
C
    8 LP = LPTR(LP)
      NEXT = ABS(LIST(LP))
      IF (NEXT .EQ. N2) GO TO 9
C
C   Set NL or NR to NEXT.
C
      IF ( LEFT(X1,Y1,X2,Y2,X(NEXT),Y(NEXT)) ) THEN
        NL = NEXT
      ELSE
        NR = NEXT
      ENDIF
      GO TO 6
C
C IWL is the number of arcs which intersect N1-N2.
C   Store LWK.
C
    9 LWK = IWL
      IWEND = IWL
C
C Initialize for edge swapping loop -- all possible swaps
C   are applied (even if the new arc again intersects
C   N1-N2), arcs to the left of N1->N2 are stored in the
C   left portion of IWK, and arcs to the right are stored in
C   the right portion.  IWF and IWL index the first and last
C   intersecting arcs.
C
      IWF = 1
C
C Top of loop -- set N0 to N1 and NL->NR to the first edge.
C   IWC points to the arc currently being processed.  LFT
C   .LE. 0 iff N0 LEFT N1->N2.
C
   10 LFT = 0
      N0 = N1
      X0 = X1
      Y0 = Y1
      NL = IWK(1,IWF)
      NR = IWK(2,IWF)
      IWC = IWF
C
C   Set NEXT to the node opposite NL->NR unless IWC is the
C     last arc.
C
   11 IF (IWC .EQ. IWL) GO TO 21
      IWCP1 = IWC + 1
      NEXT = IWK(1,IWCP1)
      IF (NEXT .NE. NL) GO TO 16
      NEXT = IWK(2,IWCP1)
C
C   NEXT RIGHT N1->N2 and IWC .LT. IWL.  Test for a possible
C     swap.
C
      IF ( .NOT. LEFT(X0,Y0,X(NR),Y(NR),X(NEXT),Y(NEXT)) )
     .   GO TO 14
      IF (LFT .GE. 0) GO TO 12
      IF ( .NOT. LEFT(X(NL),Y(NL),X0,Y0,X(NEXT),Y(NEXT)) )
     .   GO TO 14
C
C   Replace NL->NR with N0->NEXT.
C
      CALL SWAP (NEXT,N0,NL,NR, LIST,LPTR,LEND, LP21)
      IWK(1,IWC) = N0
      IWK(2,IWC) = NEXT
      GO TO 15
C
C   Swap NL-NR for N0-NEXT, shift columns IWC+1,...,IWL to
C     the left, and store N0-NEXT in the right portion of
C     IWK.
C
   12 CALL SWAP (NEXT,N0,NL,NR, LIST,LPTR,LEND, LP21)
      DO 13 I = IWCP1,IWL
        IWK(1,I-1) = IWK(1,I)
        IWK(2,I-1) = IWK(2,I)
   13   CONTINUE
      IWK(1,IWL) = N0
      IWK(2,IWL) = NEXT
      IWL = IWL - 1
      NR = NEXT
      GO TO 11
C
C   A swap is not possible.  Set N0 to NR.
C
   14 N0 = NR
      X0 = X(N0)
      Y0 = Y(N0)
      LFT = 1
C
C   Advance to the next arc.
C
   15 NR = NEXT
      IWC = IWC + 1
      GO TO 11
C
C   NEXT LEFT N1->N2, NEXT .NE. N2, and IWC .LT. IWL.
C     Test for a possible swap.
C
   16 IF ( .NOT. LEFT(X(NL),Y(NL),X0,Y0,X(NEXT),Y(NEXT)) )
     .   GO TO 19
      IF (LFT .LE. 0) GO TO 17
      IF ( .NOT. LEFT(X0,Y0,X(NR),Y(NR),X(NEXT),Y(NEXT)) )
     .   GO TO 19
C
C   Replace NL->NR with NEXT->N0.
C
      CALL SWAP (NEXT,N0,NL,NR, LIST,LPTR,LEND, LP21)
      IWK(1,IWC) = NEXT
      IWK(2,IWC) = N0
      GO TO 20
C
C   Swap NL-NR for N0-NEXT, shift columns IWF,...,IWC-1 to
C     the right, and store N0-NEXT in the left portion of
C     IWK.
C
   17 CALL SWAP (NEXT,N0,NL,NR, LIST,LPTR,LEND, LP21)
      DO 18 I = IWC-1,IWF,-1
        IWK(1,I+1) = IWK(1,I)
        IWK(2,I+1) = IWK(2,I)
   18   CONTINUE
      IWK(1,IWF) = N0
      IWK(2,IWF) = NEXT
      IWF = IWF + 1
      GO TO 20
C
C   A swap is not possible.  Set N0 to NL.
C
   19 N0 = NL
      X0 = X(N0)
      Y0 = Y(N0)
      LFT = -1
C
C   Advance to the next arc.
C
   20 NL = NEXT
      IWC = IWC + 1
      GO TO 11
C
C   N2 is opposite NL->NR (IWC = IWL).
C
   21 IF (N0 .EQ. N1) GO TO 24
      IF (LFT .LT. 0) GO TO 22
C
C   N0 RIGHT N1->N2.  Test for a possible swap.
C
      IF ( .NOT. LEFT(X0,Y0,X(NR),Y(NR),X2,Y2) ) GO TO 10
C
C   Swap NL-NR for N0-N2 and store N0-N2 in the right
C     portion of IWK.
C
      CALL SWAP (N2,N0,NL,NR, LIST,LPTR,LEND, LP21)
      IWK(1,IWL) = N0
      IWK(2,IWL) = N2
      IWL = IWL - 1
      GO TO 10
C
C   N0 LEFT N1->N2.  Test for a possible swap.
C
   22 IF ( .NOT. LEFT(X(NL),Y(NL),X0,Y0,X2,Y2) ) GO TO 10
C
C   Swap NL-NR for N0-N2, shift columns IWF,...,IWL-1 to the
C     right, and store N0-N2 in the left portion of IWK.
C
      CALL SWAP (N2,N0,NL,NR, LIST,LPTR,LEND, LP21)
      I = IWL
   23 IWK(1,I) = IWK(1,I-1)
      IWK(2,I) = IWK(2,I-1)
      I = I - 1
      IF (I .GT. IWF) GO TO 23
      IWK(1,IWF) = N0
      IWK(2,IWF) = N2
      IWF = IWF + 1
      GO TO 10
C
C IWF = IWC = IWL.  Swap out the last arc for N1-N2 and
C   store zeros in IWK.
C
   24 CALL SWAP (N2,N1,NL,NR, LIST,LPTR,LEND, LP21)
      IWK(1,IWC) = 0
      IWK(2,IWC) = 0
C
C Optimization procedure --
C
      IF (IWC .GT. 1) THEN
C
C   Optimize the set of new arcs to the left of IN1->IN2.
C
        NIT = 3*(IWC-1)
        CALL OPTIM (X,Y,IWC-1, LIST,LPTR,LEND,NIT,IWK, IERR)
        IF (IERR .NE. 0) GO TO 34
      ENDIF
      IF (IWC .LT. IWEND) THEN
C
C   Optimize the set of new arcs to the right of IN1->IN2.
C
        NIT = 3*(IWEND-IWC)
        CALL OPTIM (X,Y,IWEND-IWC, LIST,LPTR,LEND,NIT,
     .              IWK(1,IWC+1), IERR)
        IF (IERR .NE. 0) GO TO 34
      ENDIF
C
C Successful termination.
C
      IER = 0
      RETURN
C
C IN1 and IN2 were adjacent on input.
C
   30 IER = 0
      RETURN
C
C Invalid input parameter.
C
   31 IER = 1
      RETURN
C
C Insufficient space reserved for IWK.
C
   32 IER = 2
      RETURN
C
C Invalid triangulation data structure or collinear nodes
C   on convex hull boundary.
C
   33 IER = 3
      WRITE (*,130) IN1, IN2
  130 FORMAT (//5X,'*** Error in EDGE:  Invalid triangula',
     .        'tion or null triangles on boundary'/
     .        9X,'IN1 =',I4,', IN2=',I4/)
      RETURN
C
C Error flag returned by OPTIM.
C
   34 IER = 4
      WRITE (*,140) NIT, IERR
  140 FORMAT (//5X,'*** Error in OPTIM:  NIT = ',I4,
     .        ', IER = ',I1,' ***'/)
      RETURN
      END
      SUBROUTINE GETNP (NCC,LCC,N,X,Y,LIST,LPTR,LEND,
     .                  L, NPTS,DS, IER)
      INTEGER NCC, LCC(*), N, LIST(*), LPTR(*), LEND(N),
     .        L, NPTS(L), IER
      DOUBLE PRECISION X(N), Y(N), DS(L)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   11/12/94
C
C   Given a triangulation of N nodes and an array NPTS con-
C taining the indexes of L-1 nodes ordered by distance from
C NPTS(1), this subroutine sets NPTS(L) to the index of the
C next node in the sequence -- the node, other than NPTS(1),
C ...,NPTS(L-1), which is closest to NPTS(1).  Thus, the
C ordered sequence of K closest nodes to N1 (including N1)
C may be determined by K-1 calls to GETNP with NPTS(1) = N1
C and L = 2,3,...,K for K .GE. 2.  Note that NPTS must in-
C clude constraint nodes as well as non-constraint nodes.
C Thus, a sequence of K1 closest non-constraint nodes to N1
C must be obtained as a subset of the closest K2 nodes to N1
C for some K2 .GE. K1.
C
C   The terms closest and distance have special definitions
C when constraint nodes are present in the triangulation.
C Nodes N1 and N2 are said to be visible from each other if
C and only if the line segment N1-N2 intersects no con-
C straint arc (except possibly itself) and is not an interi-
C or constraint arc (arc whose interior lies in a constraint
C region).  A path from N1 to N2 is an ordered sequence of
C nodes, with N1 first and N2 last, such that adjacent path
C elements are visible from each other.  The path length is
C the sum of the Euclidean distances between adjacent path
C nodes.  Finally, the distance from N1 to N2 is defined to
C be the length of the shortest path from N1 to N2.
C
C   The algorithm uses the property of a Delaunay triangula-
C tion that the K-th closest node to N1 is a neighbor of one
C of the K-1 closest nodes to N1.  With the definition of
C distance used here, this property holds when constraints
C are present as long as non-constraint arcs are locally
C optimal.
C
C
C On input:
C
C       NCC = Number of constraints.  NCC .GE. 0.
C
C       LCC = List of constraint curve starting indexes (or
C             dummy array of length 1 if NCC = 0).  Refer to
C             Subroutine ADDCST.
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       X,Y = Arrays of length N containing the coordinates
C             of the nodes with non-constraint nodes in the
C             first LCC(1)-1 locations if NCC > 0.
C
C       LIST,LPTR,LEND = Triangulation data structure.  Re-
C                        fer to Subroutine TRMESH.
C
C       L = Number of nodes in the sequence on output.  2
C           .LE. L .LE. N.
C
C       NPTS = Array of length .GE. L containing the indexes
C              of the L-1 closest nodes to NPTS(1) in the
C              first L-1 locations.
C
C       DS = Array of length .GE. L containing the distance
C            (defined above) between NPTS(1) and NPTS(I) in
C            the I-th position for I = 1,...,L-1.  Thus,
C            DS(1) = 0.
C
C Input parameters other than NPTS(L) and DS(L) are not
C   altered by this routine.
C
C On output:
C
C       NPTS = Array updated with the index of the L-th
C              closest node to NPTS(1) in position L unless
C              IER .NE. 0.
C
C       DS = Array updated with the distance between NPTS(1)
C            and NPTS(L) in position L unless IER .NE. 0.
C
C       IER = Error indicator:
C             IER =  0 if no errors were encountered.
C             IER = -1 if NCC, N, L, or an LCC entry is
C                      outside its valid range on input.
C             IER =  K if NPTS(K) is not a valid index in
C                      the range 1 to N.
C
C Module required by GETNP:  INTSEC
C
C Intrinsic functions called by GETNP:  ABS, MIN, SQRT
C
C***********************************************************
C
      LOGICAL INTSEC
      INTEGER I, IFRST, ILAST, J, K, KM1, LCC1, LM1, LP,
     .        LPCL, LPK, LPKL, N1, NC, NF1, NF2, NJ, NK,
     .        NKBAK, NKFOR, NL, NN
      LOGICAL ISW, VIS, NCF, NJF, SKIP, SKSAV, LFT1, LFT2,
     .        LFT12
      DOUBLE PRECISION DC, DL, X1, XC, XJ, XK, Y1, YC, YJ,
     .        YK
C
C Store parameters in local variables and test for errors.
C   LCC1 indexes the first constraint node.
C
      IER = -1
      NN = N
      LCC1 = NN+1
      LM1 = L-1
      IF (NCC .LT. 0  .OR.  LM1 .LT. 1  .OR.  LM1 .GE. NN)
     .   RETURN
      IF (NCC .EQ. 0) THEN
        IF (NN .LT. 3) RETURN
      ELSE
        DO 1 I = NCC,1,-1
          IF (LCC1 - LCC(I) .LT. 3) RETURN
          LCC1 = LCC(I)
    1     CONTINUE
        IF (LCC1 .LT. 1) RETURN
      ENDIF
C
C Test for an invalid index in NPTS.
C
      DO 2 K = 1,LM1
        NK = NPTS(K)
        IF (NK .LT. 1  .OR.  NK .GT. NN) THEN
          IER = K
          RETURN
        ENDIF
    2   CONTINUE
C
C Store N1 = NPTS(1) and mark the elements of NPTS.
C
      N1 = NPTS(1)
      X1 = X(N1)
      Y1 = Y(N1)
      DO 3 K = 1,LM1
        NK = NPTS(K)
        LEND(NK) = -LEND(NK)
    3   CONTINUE
C
C Candidates NC for NL = NPTS(L) are the unmarked visible
C   neighbors of nodes NK in NPTS.  ISW is an initialization
C   switch set to .TRUE. when NL and its distance DL from N1
C   have been initialized with the first candidate encount-
C   ered.
C
      ISW = .FALSE.
      DL = 0.
C
C Loop on marked nodes NK = NPTS(K).  LPKL indexes the last
C   neighbor of NK in LIST.
C
      DO 16 K = 1,LM1
        KM1 = K - 1
        NK = NPTS(K)
        XK = X(NK)
        YK = Y(NK)
        LPKL = -LEND(NK)
        NKFOR = 0
        NKBAK = 0
        VIS = .TRUE.
        IF (NK .GE. LCC1) THEN
C
C   NK is a constraint node.  Set NKFOR and NKBAK to the
C     constraint nodes which follow and precede NK.  IFRST
C     and ILAST are set to the first and last nodes in the
C     constraint containing NK.
C
          IFRST = NN + 1
          DO 4 I = NCC,1,-1
            ILAST = IFRST - 1
            IFRST = LCC(I)
            IF (NK .GE. IFRST) GO TO 5
    4       CONTINUE
C
    5     IF (NK .LT. ILAST) THEN
            NKFOR = NK + 1
          ELSE
            NKFOR = IFRST
          ENDIF
          IF (NK .GT. IFRST) THEN
            NKBAK = NK - 1
          ELSE
            NKBAK = ILAST
          ENDIF
C
C   Initialize VIS to TRUE iff NKFOR precedes NKBAK in the
C     adjacency list for NK -- the first neighbor is visi-
C     ble and is not NKBAK.
C
          LPK = LPKL
    6     LPK = LPTR(LPK)
            NC = ABS(LIST(LPK))
            IF (NC .NE. NKFOR  .AND.  NC .NE. NKBAK) GO TO 6
          VIS = NC .EQ. NKFOR
        ENDIF
C
C Loop on neighbors NC of NK, bypassing marked and nonvis-
C   ible neighbors.
C
        LPK = LPKL
    7   LPK = LPTR(LPK)
          NC = ABS(LIST(LPK))
          IF (NC .EQ. NKBAK) VIS = .TRUE.
C
C   VIS = .FALSE. iff NK-NC is an interior constraint arc
C     (NK is a constraint node and NC lies strictly between
C     NKFOR and NKBAK).
C
          IF (.NOT. VIS) GO TO 15
          IF (NC .EQ. NKFOR) VIS = .FALSE.
          IF (LEND(NC) .LT. 0) GO TO 15
C
C Initialize distance DC between N1 and NC to Euclidean
C   distance.
C
          XC = X(NC)
          YC = Y(NC)
          DC = SQRT((XC-X1)*(XC-X1) + (YC-Y1)*(YC-Y1))
          IF (ISW  .AND.  DC .GE. DL) GO TO 15
          IF (K .EQ. 1) GO TO 14
C
C K .GE. 2.  Store the pointer LPCL to the last neighbor
C   of NC.
C
          LPCL = LEND(NC)
C
C Set DC to the length of the shortest path from N1 to NC
C   which has not previously been encountered and which is
C   a viable candidate for the shortest path from N1 to NL.
C   This is Euclidean distance iff NC is visible from N1.
C   Since the shortest path from N1 to NL contains only ele-
C   ments of NPTS which are constraint nodes (in addition to
C   N1 and NL), only these need be considered for the path
C   from N1 to NC.  Thus, for distance function D(A,B) and
C   J = 1,...,K, DC = min(D(N1,NJ) + D(NJ,NC)) over con-
C   straint nodes NJ = NPTS(J) which are visible from NC.
C
          DO 13 J = 1,KM1
            NJ = NPTS(J)
            IF (J .GT. 1  .AND.  NJ .LT. LCC1) GO TO 13
C
C If NC is a visible neighbor of NJ, a path from N1 to NC
C   containing NJ has already been considered.  Thus, NJ may
C   be bypassed if it is adjacent to NC.
C
            LP = LPCL
    8       LP = LPTR(LP)
              IF ( NJ .EQ. ABS(LIST(LP)) ) GO TO 12
              IF (LP .NE. LPCL) GO TO 8
C
C NJ is a constraint node (unless J=1) not adjacent to NC,
C   and is visible from NC iff NJ-NC is not intersected by
C   a constraint arc.  Loop on constraints I in reverse
C   order --
C
            XJ = X(NJ)
            YJ = Y(NJ)
            IFRST = NN+1
            DO 11 I = NCC,1,-1
              ILAST = IFRST - 1
              IFRST = LCC(I)
              NF1 = ILAST
              NCF = NF1 .EQ. NC
              NJF = NF1 .EQ. NJ
              SKIP = NCF  .OR.  NJF
C
C Loop on boundary constraint arcs NF1-NF2 which contain
C   neither NC nor NJ.  NCF and NJF are TRUE iff NC (or NJ)
C   has been encountered in the constraint, and SKIP =
C   .TRUE. iff NF1 = NC or NF1 = NJ.
C
              DO 10 NF2 = IFRST,ILAST
                IF (NF2 .EQ. NC) NCF = .TRUE.
                IF (NF2 .EQ. NJ) NJF = .TRUE.
                SKSAV = SKIP
                SKIP = NF2 .EQ. NC  .OR.  NF2 .EQ. NJ
C
C   The last constraint arc in the constraint need not be
C     tested if none of the arcs have been skipped.
C
                IF ( SKSAV  .OR.  SKIP  .OR.
     .               (NF2 .EQ. ILAST  .AND.
     .               .NOT. NCF  .AND.  .NOT. NJF) ) GO TO 9
                IF ( INTSEC(X(NF1),Y(NF1),X(NF2),Y(NF2),
     .                      XC,YC,XJ,YJ) ) GO TO 12
    9           NF1 = NF2
   10           CONTINUE
              IF (.NOT. NCF  .OR.  .NOT. NJF) GO TO 11
C
C NC and NJ are constraint nodes in the same constraint.
C   NC-NJ is intersected by an interior constraint arc iff
C   1)  NC LEFT NF2->NF1 and (NJ LEFT NF1->NC and NJ LEFT
C         NC->NF2) or
C   2)  NC .NOT. LEFT NF2->NF1 and (NJ LEFT NF1->NC or
C         NJ LEFT NC->NF2),
C   where NF1, NC, NF2 are consecutive constraint nodes.
C
              IF (NC .NE. IFRST) THEN
                NF1 = NC - 1
              ELSE
                NF1 = ILAST
              ENDIF
              IF (NC .NE. ILAST) THEN
                NF2 = NC + 1
              ELSE
                NF2 = IFRST
              ENDIF
              LFT1 = (XC-X(NF1))*(YJ-Y(NF1)) .GE.
     .               (XJ-X(NF1))*(YC-Y(NF1))
              LFT2 = (X(NF2)-XC)*(YJ-YC) .GE.
     .               (XJ-XC)*(Y(NF2)-YC)
              LFT12 = (X(NF1)-X(NF2))*(YC-Y(NF2)) .GE.
     .                (XC-X(NF2))*(Y(NF1)-Y(NF2))
              IF ( (LFT1  .AND.  LFT2)  .OR.  (.NOT. LFT12
     .             .AND.  (LFT1  .OR.  LFT2)) ) GO TO 12
   11         CONTINUE
C
C NJ is visible from NC.  Exit the loop with DC = Euclidean
C   distance if J = 1.
C
            IF (J .EQ. 1) GO TO 14
            DC = MIN(DC,DS(J) + SQRT((XC-XJ)*(XC-XJ) +
     .                  (YC-YJ)*(YC-YJ)))
            GO TO 13
C
C NJ is not visible from NC or is adjacent to NC.  Initial-
C   ize DC with D(N1,NK) + D(NK,NC) if J = 1.
C
   12       IF (J .EQ. 1) DC = DS(K) + SQRT((XC-XK)*(XC-XK)
     .                         + (YC-YK)*(YC-YK))
   13       CONTINUE
C
C Compare DC with DL.
C
          IF (ISW  .AND.  DC .GE. DL) GO TO 15
C
C The first (or a closer) candidate for NL has been
C   encountered.
C
   14     NL = NC
          DL = DC
          ISW = .TRUE.
   15     IF (LPK .NE. LPKL) GO TO 7
   16   CONTINUE
C
C Unmark the elements of NPTS and store NL and DL.
C
      DO 17 K = 1,LM1
        NK = NPTS(K)
        LEND(NK) = -LEND(NK)
   17   CONTINUE
      NPTS(L) = NL
      DS(L) = DL
      IER = 0
      RETURN
      END
      INTEGER FUNCTION INDXCC (NCC,LCC,N,LIST,LEND)
      INTEGER NCC, LCC(*), N, LIST(*), LEND(N)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   08/25/91
C
C   Given a constrained Delaunay triangulation, this func-
C tion returns the index, if any, of an exterior constraint
C curve (an unbounded constraint region).  An exterior con-
C straint curve is assumed to be present if and only if the
C clockwise-ordered sequence of boundary nodes is a subse-
C quence of a constraint node sequence.  The triangulation
C adjacencies corresponding to constraint edges may or may
C not have been forced by a call to ADDCST, and the con-
C straint region may or may not be valid (contain no nodes).
C
C
C On input:
C
C       NCC = Number of constraints.  NCC .GE. 0.
C
C       LCC = List of constraint curve starting indexes (or
C             dummy array of length 1 if NCC = 0).  Refer to
C             Subroutine ADDCST.
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       LIST,LEND = Data structure defining the triangula-
C                   tion.  Refer to Subroutine TRMESH.
C
C   Input parameters are not altered by this function.  Note
C that the parameters are not tested for validity.
C
C On output:
C
C       INDXCC = Index of the exterior constraint curve, if
C                present, or 0 otherwise.
C
C Modules required by INDXCC:  None
C
C***********************************************************
C
      INTEGER I, IFRST, ILAST, LP, N0, NST, NXT
      INDXCC = 0
      IF (NCC .LT. 1) RETURN
C
C Set N0 to the boundary node with smallest index.
C
      N0 = 0
    1 N0 = N0 + 1
        LP = LEND(N0)
        IF (LIST(LP) .GT. 0) GO TO 1
C
C Search in reverse order for the constraint I, if any, that
C   contains N0.  IFRST and ILAST index the first and last
C   nodes in constraint I.
C
      I = NCC
      ILAST = N
    2 IFRST = LCC(I)
        IF (N0 .GE. IFRST) GO TO 3
        IF (I .EQ. 1) RETURN
        I = I - 1
        ILAST = IFRST - 1
        GO TO 2
C
C N0 is in constraint I which indexes an exterior constraint
C   curve iff the clockwise-ordered sequence of boundary
C   node indexes beginning with N0 is increasing and bounded
C   above by ILAST.
C
    3 NST = N0
C
    4 NXT = -LIST(LP)
        IF (NXT .EQ. NST) GO TO 5
        IF (NXT .LE. N0  .OR.  NXT .GT. ILAST) RETURN
        N0 = NXT
        LP = LEND(N0)
        GO TO 4
C
C Constraint I contains the boundary node sequence as a
C   subset.
C
    5 INDXCC = I
      RETURN
      END
      SUBROUTINE INSERT (K,LP, LIST,LPTR,LNEW )
      INTEGER K, LP, LIST(*), LPTR(*), LNEW
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C   This subroutine inserts K as a neighbor of N1 following
C N2, where LP is the LIST pointer of N2 as a neighbor of
C N1.  Note that, if N2 is the last neighbor of N1, K will
C become the first neighbor (even if N1 is a boundary node).
C
C
C On input:
C
C       K = Index of the node to be inserted.
C
C       LP = LIST pointer of N2 as a neighbor of N1.
C
C The above parameters are not altered by this routine.
C
C       LIST,LPTR,LNEW = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C On output:
C
C       LIST,LPTR,LNEW = Data structure updated with the
C                        addition of node K.
C
C Modules required by INSERT:  None
C
C***********************************************************
C
      INTEGER LSAV
C
      LSAV = LPTR(LP)
      LPTR(LP) = LNEW
      LIST(LNEW) = K
      LPTR(LNEW) = LSAV
      LNEW = LNEW + 1
      RETURN
      END
      SUBROUTINE INTADD (KK,I1,I2,I3, LIST,LPTR,LEND,LNEW )
      INTEGER KK, I1, I2, I3, LIST(*), LPTR(*), LEND(*),
     .        LNEW
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   02/22/91
C
C   This subroutine adds an interior node to a triangulation
C of a set of points in the plane.  The data structure is
C updated with the insertion of node KK into the triangle
C whose vertices are I1, I2, and I3.  No optimization of the
C triangulation is performed.
C
C
C On input:
C
C       KK = Index of the node to be inserted.  KK .GE. 1
C            and KK must not be equal to I1, I2, or I3.
C
C       I1,I2,I3 = Indexes of the counterclockwise-ordered
C                  sequence of vertices of a triangle which
C                  contains node KK.
C
C The above parameters are not altered by this routine.
C
C       LIST,LPTR,LEND,LNEW = Data structure defining the
C                             triangulation.  Refer to Sub-
C                             routine TRMESH.  Triangle
C                             (I1,I2,I3) must be included
C                             in the triangulation.
C
C On output:
C
C       LIST,LPTR,LEND,LNEW = Data structure updated with
C                             the addition of node KK.  KK
C                             will be connected to nodes I1,
C                             I2, and I3.
C
C Modules required by INTADD:  INSERT, LSTPTR
C
C***********************************************************
C
      INTEGER LSTPTR
      INTEGER K, LP, N1, N2, N3
      K = KK
C
C Initialization.
C
      N1 = I1
      N2 = I2
      N3 = I3
C
C Add K as a neighbor of I1, I2, and I3.
C
      LP = LSTPTR(LEND(N1),N2,LIST,LPTR)
      CALL INSERT (K,LP,LIST,LPTR,LNEW)
      LP = LSTPTR(LEND(N2),N3,LIST,LPTR)
      CALL INSERT (K,LP,LIST,LPTR,LNEW)
      LP = LSTPTR(LEND(N3),N1,LIST,LPTR)
      CALL INSERT (K,LP,LIST,LPTR,LNEW)
C
C Add I1, I2, and I3 as neighbors of K.
C
      LIST(LNEW) = N1
      LIST(LNEW+1) = N2
      LIST(LNEW+2) = N3
      LPTR(LNEW) = LNEW + 1
      LPTR(LNEW+1) = LNEW + 2
      LPTR(LNEW+2) = LNEW
      LEND(K) = LNEW + 2
      LNEW = LNEW + 3
      RETURN
      END
      LOGICAL FUNCTION INTSEC (X1,Y1,X2,Y2,X3,Y3,X4,Y4)
      DOUBLE PRECISION X1, Y1, X2, Y2, X3, Y3, X4, Y4
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C   Given a pair of line segments P1-P2 and P3-P4, this
C function returns the value .TRUE. if and only if P1-P2
C shares one or more points with P3-P4.  The line segments
C include their endpoints, and the four points need not be
C distinct.  Thus, either line segment may consist of a
C single point, and the segments may meet in a V (which is
C treated as an intersection).  Note that an incorrect
C decision may result from floating point error if the four
C endpoints are nearly collinear.
C
C
C On input:
C
C       X1,Y1 = Coordinates of P1.
C
C       X2,Y2 = Coordinates of P2.
C
C       X3,Y3 = Coordinates of P3.
C
C       X4,Y4 = Coordinates of P4.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       INTSEC = Logical value defined above.
C
C Modules required by INTSEC:  None
C
C***********************************************************
C
      DOUBLE PRECISION A, B, D, DX12, DX31, DX34, DY12,
     .        DY31, DY34
C
C Test for overlap between the smallest rectangles that
C   contain the line segments and have sides parallel to
C   the axes.
C
      IF ((X1 .LT. X3  .AND.  X1 .LT. X4  .AND.  X2 .LT. X3
     .     .AND.  X2 .LT. X4)  .OR.
     .    (X1 .GT. X3  .AND.  X1 .GT. X4  .AND.  X2 .GT. X3
     .     .AND.  X2 .GT. X4)  .OR.
     .    (Y1 .LT. Y3  .AND.  Y1 .LT. Y4  .AND.  Y2 .LT. Y3
     .     .AND.  Y2 .LT. Y4)  .OR.
     .    (Y1 .GT. Y3  .AND.  Y1 .GT. Y4  .AND.  Y2 .GT. Y3
     .     .AND.  Y2 .GT. Y4)) THEN
        INTSEC = .FALSE.
        RETURN
      ENDIF
C
C Compute A = P4-P3 X P1-P3, B = P2-P1 X P1-P3, and
C   D = P2-P1 X P4-P3 (Z components).
C
      DX12 = X2 - X1
      DY12 = Y2 - Y1
      DX34 = X4 - X3
      DY34 = Y4 - Y3
      DX31 = X1 - X3
      DY31 = Y1 - Y3
      A = DX34*DY31 - DX31*DY34
      B = DX12*DY31 - DX31*DY12
      D = DX12*DY34 - DX34*DY12
      IF (D .EQ. 0.) GO TO 1
C
C D .NE. 0 and the point of intersection of the lines de-
C   fined by the line segments is P = P1 + (A/D)*(P2-P1) =
C   P3 + (B/D)*(P4-P3).
C
      INTSEC = A/D .GE. 0.  .AND.  A/D .LE. 1.  .AND.
     .         B/D .GE. 0.  .AND.  B/D .LE. 1.
      RETURN
C
C D .EQ. 0 and thus either the line segments are parallel,
C   or one (or both) of them is a single point.
C
    1 INTSEC = A .EQ. 0.  .AND.  B .EQ. 0.
      RETURN
      END
      INTEGER FUNCTION JRAND (N, IX,IY,IZ )
      INTEGER N, IX, IY, IZ
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/28/98
C
C   This function returns a uniformly distributed pseudo-
C random integer in the range 1 to N.
C
C
C On input:
C
C       N = Maximum value to be returned.
C
C N is not altered by this function.
C
C       IX,IY,IZ = Integer seeds initialized to values in
C                  the range 1 to 30,000 before the first
C                  call to JRAND, and not altered between
C                  subsequent calls (unless a sequence of
C                  random numbers is to be repeated by
C                  reinitializing the seeds).
C
C On output:
C
C       IX,IY,IZ = Updated integer seeds.
C
C       JRAND = Random integer in the range 1 to N.
C
C Reference:  B. A. Wichmann and I. D. Hill, "An Efficient
C             and Portable Pseudo-random Number Generator",
C             Applied Statistics, Vol. 31, No. 2, 1982,
C             pp. 188-190.
C
C Modules required by JRAND:  None
C
C Intrinsic functions called by JRAND:  INT, MOD, DBLE
C
C***********************************************************
C
      DOUBLE PRECISION U, X
C
C Local parameters:
C
C U = Pseudo-random number uniformly distributed in the
C     interval (0,1).
C X = Pseudo-random number in the range 0 to 3 whose frac-
C       tional part is U.
C
      IX = MOD(171*IX,30269)
      IY = MOD(172*IY,30307)
      IZ = MOD(170*IZ,30323)
      X = (DBLE(IX)/30269.) + (DBLE(IY)/30307.) +
     .    (DBLE(IZ)/30323.)
      U = X - INT(X)
      JRAND = DBLE(N)*U + 1.
      RETURN
      END
      LOGICAL FUNCTION LEFT (X1,Y1,X2,Y2,X0,Y0)
      DOUBLE PRECISION X1, Y1, X2, Y2, X0, Y0
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C   This function determines whether node N0 is to the left
C or to the right of the line through N1-N2 as viewed by an
C observer at N1 facing N2.
C
C
C On input:
C
C       X1,Y1 = Coordinates of N1.
C
C       X2,Y2 = Coordinates of N2.
C
C       X0,Y0 = Coordinates of N0.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       LEFT = .TRUE. if and only if (X0,Y0) is on or to the
C              left of the directed line N1->N2.
C
C Modules required by LEFT:  None
C
C***********************************************************
C
      DOUBLE PRECISION DX1, DY1, DX2, DY2
C
C Local parameters:
C
C DX1,DY1 = X,Y components of the vector N1->N2
C DX2,DY2 = X,Y components of the vector N1->N0
C
      DX1 = X2-X1
      DY1 = Y2-Y1
      DX2 = X0-X1
      DY2 = Y0-Y1
C
C If the sign of the vector cross product of N1->N2 and
C   N1->N0 is positive, then sin(A) > 0, where A is the
C   angle between the vectors, and thus A is in the range
C   (0,180) degrees.
C
      LEFT = DX1*DY2 .GE. DX2*DY1
      RETURN
      END
      INTEGER FUNCTION LSTPTR (LPL,NB,LIST,LPTR)
      INTEGER LPL, NB, LIST(*), LPTR(*)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C   This function returns the index (LIST pointer) of NB in
C the adjacency list for N0, where LPL = LEND(N0).
C
C
C On input:
C
C       LPL = LEND(N0)
C
C       NB = Index of the node whose pointer is to be re-
C            turned.  NB must be connected to N0.
C
C       LIST,LPTR = Data structure defining the triangula-
C                   tion.  Refer to Subroutine TRMESH.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       LSTPTR = Pointer such that LIST(LSTPTR) = NB or
C                LIST(LSTPTR) = -NB, unless NB is not a
C                neighbor of N0, in which case LSTPTR = LPL.
C
C Modules required by LSTPTR:  None
C
C***********************************************************
C
      INTEGER LP, ND
C
      LP = LPTR(LPL)
    1 ND = LIST(LP)
        IF (ND .EQ. NB) GO TO 2
        LP = LPTR(LP)
        IF (LP .NE. LPL) GO TO 1
C
    2 LSTPTR = LP
      RETURN
      END
      INTEGER FUNCTION NBCNT (LPL,LPTR)
      INTEGER LPL, LPTR(*)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C   This function returns the number of neighbors of a node
C N0 in a triangulation created by Subroutine TRMESH (or
C TRMSHR).
C
C
C On input:
C
C       LPL = LIST pointer to the last neighbor of N0 --
C             LPL = LEND(N0).
C
C       LPTR = Array of pointers associated with LIST.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       NBCNT = Number of neighbors of N0.
C
C Modules required by NBCNT:  None
C
C***********************************************************
C
      INTEGER K, LP
C
      LP = LPL
      K = 1
C
    1 LP = LPTR(LP)
        IF (LP .EQ. LPL) GO TO 2
        K = K + 1
        GO TO 1
C
    2 NBCNT = K
      RETURN
      END
      INTEGER FUNCTION NEARND (XP,YP,IST,N,X,Y,LIST,LPTR,
     .                         LEND, DSQ)
      INTEGER IST, N, LIST(*), LPTR(*), LEND(N)
      DOUBLE PRECISION XP, YP, X(N), Y(N), DSQ
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/27/98
C
C   Given a point P in the plane and a Delaunay triangula-
C tion created by Subroutine TRMESH or TRMSHR, this function
C returns the index of the nearest triangulation node to P.
C
C   The algorithm consists of implicitly adding P to the
C triangulation, finding the nearest neighbor to P, and
C implicitly deleting P from the triangulation.  Thus, it
C is based on the fact that, if P is a node in a Delaunay
C triangulation, the nearest node to P is a neighbor of P.
C
C
C On input:
C
C       XP,YP = Cartesian coordinates of the point P to be
C               located relative to the triangulation.
C
C       IST = Index of a node at which TRFIND begins the
C             search.  Search time depends on the proximity
C             of this node to P.
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       X,Y = Arrays of length N containing the Cartesian
C             coordinates of the nodes.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to TRMESH.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       NEARND = Nodal index of the nearest node to P, or 0
C                if N < 3 or the triangulation data struc-
C                ture is invalid.
C
C       DSQ = Squared distance between P and NEARND unless
C             NEARND = 0.
C
C       Note that the number of candidates for NEARND
C       (neighbors of P) is limited to LMAX defined in
C       the PARAMETER statement below.
C
C Modules required by NEARND:  JRAND, LEFT, LSTPTR, TRFIND
C
C Intrinsic function called by NEARND:  ABS
C
C***********************************************************
C
      INTEGER   LSTPTR
      INTEGER   LMAX
      PARAMETER (LMAX=25)
      INTEGER   I1, I2, I3, L, LISTP(LMAX), LP, LP1, LP2,
     .          LPL, LPTRP(LMAX), N1, N2, N3, NR, NST
      DOUBLE PRECISION   COS1, COS2, DS1, DSR, DX11, DX12,
     .          DX21, DX22, DY11, DY12, DY21, DY22, SIN1,
     .          SIN2
C
C Store local parameters and test for N invalid.
C
      IF (N .LT. 3) GO TO 7
      NST = IST
      IF (NST .LT. 1  .OR.  NST .GT. N) NST = 1
C
C Find a triangle (I1,I2,I3) containing P, or the rightmost
C   (I1) and leftmost (I2) visible boundary nodes as viewed
C   from P.
C
      CALL TRFIND (NST,XP,YP,N,X,Y,LIST,LPTR,LEND, I1,I2,I3)
C
C Test for collinear nodes.
C
      IF (I1 .EQ. 0) GO TO 7
C
C Store the linked list of 'neighbors' of P in LISTP and
C   LPTRP.  I1 is the first neighbor, and 0 is stored as
C   the last neighbor if P is not contained in a triangle.
C   L is the length of LISTP and LPTRP, and is limited to
C   LMAX.
C
      IF (I3 .NE. 0) THEN
        LISTP(1) = I1
        LPTRP(1) = 2
        LISTP(2) = I2
        LPTRP(2) = 3
        LISTP(3) = I3
        LPTRP(3) = 1
        L = 3
      ELSE
        N1 = I1
        L = 1
        LP1 = 2
        LISTP(L) = N1
        LPTRP(L) = LP1
C
C   Loop on the ordered sequence of visible boundary nodes
C     N1 from I1 to I2.
C
    1   LPL = LEND(N1)
          N1 = -LIST(LPL)
          L = LP1
          LP1 = L+1
          LISTP(L) = N1
          LPTRP(L) = LP1
          IF (N1 .NE. I2  .AND.  LP1 .LT. LMAX) GO TO 1
        L = LP1
        LISTP(L) = 0
        LPTRP(L) = 1
      ENDIF
C
C Initialize variables for a loop on arcs N1-N2 opposite P
C   in which new 'neighbors' are 'swapped' in.  N1 follows
C   N2 as a neighbor of P, and LP1 and LP2 are the LISTP
C   indexes of N1 and N2.
C
      LP2 = 1
      N2 = I1
      LP1 = LPTRP(1)
      N1 = LISTP(LP1)
C
C Begin loop:  find the node N3 opposite N1->N2.
C
    2 LP = LSTPTR(LEND(N1),N2,LIST,LPTR)
        IF (LIST(LP) .LT. 0) GO TO 4
        LP = LPTR(LP)
        N3 = ABS(LIST(LP))
C
C Swap test:  Exit the loop if L = LMAX.
C
        IF (L .EQ. LMAX) GO TO 5
        DX11 = X(N1) - X(N3)
        DX12 = X(N2) - X(N3)
        DX22 = X(N2) - XP
        DX21 = X(N1) - XP
C
        DY11 = Y(N1) - Y(N3)
        DY12 = Y(N2) - Y(N3)
        DY22 = Y(N2) - YP
        DY21 = Y(N1) - YP
C
        COS1 = DX11*DX12 + DY11*DY12
        COS2 = DX22*DX21 + DY22*DY21
        IF (COS1 .GE. 0.  .AND.  COS2 .GE. 0.) GO TO 4
        IF (COS1 .LT. 0.  .AND.  COS2 .LT. 0.) GO TO 3
C
        SIN1 = DX11*DY12 - DX12*DY11
        SIN2 = DX22*DY21 - DX21*DY22
        IF (SIN1*COS2 + COS1*SIN2 .GE. 0.) GO TO 4
C
C Swap:  Insert N3 following N2 in the adjacency list for P.
C        The two new arcs opposite P must be tested.
C
    3   L = L+1
        LPTRP(LP2) = L
        LISTP(L) = N3
        LPTRP(L) = LP1
        LP1 = L
        N1 = N3
        GO TO 2
C
C No swap:  Advance to the next arc and test for termination
C           on N1 = I1 (LP1 = 1) or N1 followed by 0.
C
    4   IF (LP1 .EQ. 1) GO TO 5
        LP2 = LP1
        N2 = N1
        LP1 = LPTRP(LP1)
        N1 = LISTP(LP1)
        IF (N1 .EQ. 0) GO TO 5
        GO TO 2
C
C Set NR and DSR to the index of the nearest node to P and
C   its squared distance from P, respectively.
C
    5 NR = I1
      DSR = (X(NR)-XP)**2 + (Y(NR)-YP)**2
      DO 6 LP = 2,L
        N1 = LISTP(LP)
        IF (N1 .EQ. 0) GO TO 6
        DS1 = (X(N1)-XP)**2 + (Y(N1)-YP)**2
        IF (DS1 .LT. DSR) THEN
          NR = N1
          DSR = DS1
        ENDIF
    6   CONTINUE
      DSQ = DSR
      NEARND = NR
      RETURN
C
C Invalid input.
C
    7 NEARND = 0
      RETURN
      END
      SUBROUTINE OPTIM (X,Y,NA, LIST,LPTR,LEND,NIT,IWK, IER)
      INTEGER NA, LIST(*), LPTR(*), LEND(*), NIT, IWK(2,NA),
     .        IER
      DOUBLE PRECISION X(*), Y(*)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/27/98
C
C   Given a set of NA triangulation arcs, this subroutine
C optimizes the portion of the triangulation consisting of
C the quadrilaterals (pairs of adjacent triangles) which
C have the arcs as diagonals by applying the circumcircle
C test and appropriate swaps to the arcs.
C
C   An iteration consists of applying the swap test and
C swaps to all NA arcs in the order in which they are
C stored.  The iteration is repeated until no swap occurs
C or NIT iterations have been performed.  The bound on the
C number of iterations may be necessary to prevent an
C infinite loop caused by cycling (reversing the effect of a
C previous swap) due to floating point inaccuracy when four
C or more nodes are nearly cocircular.
C
C
C On input:
C
C       X,Y = Arrays containing the nodal coordinates.
C
C       NA = Number of arcs in the set.  NA .GE. 0.
C
C The above parameters are not altered by this routine.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C       NIT = Maximum number of iterations to be performed.
C             A reasonable value is 3*NA.  NIT .GE. 1.
C
C       IWK = Integer array dimensioned 2 by NA containing
C             the nodal indexes of the arc endpoints (pairs
C             of endpoints are stored in columns).
C
C On output:
C
C       LIST,LPTR,LEND = Updated triangulation data struc-
C                        ture reflecting the swaps.
C
C       NIT = Number of iterations performed.
C
C       IWK = Endpoint indexes of the new set of arcs
C             reflecting the swaps.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if a swap occurred on the last of
C                     MAXIT iterations, where MAXIT is the
C                     value of NIT on input.  The new set
C                     of arcs in not necessarily optimal
C                     in this case.
C             IER = 2 if NA < 0 or NIT < 1 on input.
C             IER = 3 if IWK(2,I) is not a neighbor of
C                     IWK(1,I) for some I in the range 1
C                     to NA.  A swap may have occurred in
C                     this case.
C             IER = 4 if a zero pointer was returned by
C                     Subroutine SWAP.
C
C Modules required by OPTIM:  LSTPTR, SWAP, SWPTST
C
C Intrinsic function called by OPTIM:  ABS
C
C***********************************************************
C
      LOGICAL SWPTST
      INTEGER I, IO1, IO2, ITER, LP, LP21, LPL, LPP, MAXIT,
     .        N1, N2, NNA
      LOGICAL SWP
C
C Local parameters:
C
C I =       Column index for IWK
C IO1,IO2 = Nodal indexes of the endpoints of an arc in IWK
C ITER =    Iteration count
C LP =      LIST pointer
C LP21 =    Parameter returned by SWAP (not used)
C LPL =     Pointer to the last neighbor of IO1
C LPP =     Pointer to the node preceding IO2 as a neighbor
C             of IO1
C MAXIT =   Input value of NIT
C N1,N2 =   Nodes opposite IO1->IO2 and IO2->IO1,
C             respectively
C NNA =     Local copy of NA
C SWP =     Flag set to TRUE iff a swap occurs in the
C             optimization loop
C
      NNA = NA
      MAXIT = NIT
      IF (NNA .LT. 0  .OR.  MAXIT .LT. 1) GO TO 7
C
C Initialize iteration count ITER and test for NA = 0.
C
      ITER = 0
      IF (NNA .EQ. 0) GO TO 5
C
C Top of loop --
C   SWP = TRUE iff a swap occurred in the current iteration.
C
    1 IF (ITER .EQ. MAXIT) GO TO 6
      ITER = ITER + 1
      SWP = .FALSE.
C
C   Inner loop on arcs IO1-IO2 --
C
      DO 4 I = 1,NNA
        IO1 = IWK(1,I)
        IO2 = IWK(2,I)
C
C   Set N1 and N2 to the nodes opposite IO1->IO2 and
C     IO2->IO1, respectively.  Determine the following:
C
C     LPL = pointer to the last neighbor of IO1,
C     LP = pointer to IO2 as a neighbor of IO1, and
C     LPP = pointer to the node N2 preceding IO2.
C
        LPL = LEND(IO1)
        LPP = LPL
        LP = LPTR(LPP)
    2   IF (LIST(LP) .EQ. IO2) GO TO 3
          LPP = LP
          LP = LPTR(LPP)
          IF (LP .NE. LPL) GO TO 2
C
C   IO2 should be the last neighbor of IO1.  Test for no
C     arc and bypass the swap test if IO1 is a boundary
C     node.
C
        IF (ABS(LIST(LP)) .NE. IO2) GO TO 8
        IF (LIST(LP) .LT. 0) GO TO 4
C
C   Store N1 and N2, or bypass the swap test if IO1 is a
C     boundary node and IO2 is its first neighbor.
C
    3   N2 = LIST(LPP)
        IF (N2 .LT. 0) GO TO 4
        LP = LPTR(LP)
        N1 = ABS(LIST(LP))
C
C   Test IO1-IO2 for a swap, and update IWK if necessary.
C
        IF ( .NOT. SWPTST(N1,N2,IO1,IO2,X,Y) ) GO TO 4
        CALL SWAP (N1,N2,IO1,IO2, LIST,LPTR,LEND, LP21)
        IF (LP21 .EQ. 0) GO TO 9
        SWP = .TRUE.
        IWK(1,I) = N1
        IWK(2,I) = N2
    4   CONTINUE
      IF (SWP) GO TO 1
C
C Successful termination.
C
    5 NIT = ITER
      IER = 0
      RETURN
C
C MAXIT iterations performed without convergence.
C
    6 NIT = MAXIT
      IER = 1
      RETURN
C
C Invalid input parameter.
C
    7 NIT = 0
      IER = 2
      RETURN
C
C IO2 is not a neighbor of IO1.
C
    8 NIT = ITER
      IER = 3
      RETURN
C
C Zero pointer returned by SWAP.
C
    9 NIT = ITER
      IER = 4
      RETURN
      END
      DOUBLE PRECISION FUNCTION STORE (X)
      DOUBLE PRECISION X
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   03/18/90
C
C   This function forces its argument X to be stored in a
C memory location, thus providing a means of determining
C floating point number characteristics (such as the machine
C precision) when it is necessary to avoid computation in
C high precision registers.
C
C
C On input:
C
C       X = Value to be stored.
C
C X is not altered by this function.
C
C On output:
C
C       STORE = Value of X after it has been stored and
C               possibly truncated or rounded to the single
C               precision word length.
C
C Modules required by STORE:  None
C
C***********************************************************
C
      DOUBLE PRECISION Y
      COMMON/STCOM/Y
C
      Y = X
      STORE = Y
      RETURN
      END
      SUBROUTINE SWAP (IN1,IN2,IO1,IO2, LIST,LPTR,
     .                 LEND, LP21)
      INTEGER IN1, IN2, IO1, IO2, LIST(*), LPTR(*), LEND(*),
     .        LP21
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/22/98
C
C   Given a triangulation of a set of points on the unit
C sphere, this subroutine replaces a diagonal arc in a
C strictly convex quadrilateral (defined by a pair of adja-
C cent triangles) with the other diagonal.  Equivalently, a
C pair of adjacent triangles is replaced by another pair
C having the same union.
C
C
C On input:
C
C       IN1,IN2,IO1,IO2 = Nodal indexes of the vertices of
C                         the quadrilateral.  IO1-IO2 is re-
C                         placed by IN1-IN2.  (IO1,IO2,IN1)
C                         and (IO2,IO1,IN2) must be trian-
C                         gles on input.
C
C The above parameters are not altered by this routine.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C On output:
C
C       LIST,LPTR,LEND = Data structure updated with the
C                        swap -- triangles (IO1,IO2,IN1) and
C                        (IO2,IO1,IN2) are replaced by
C                        (IN1,IN2,IO2) and (IN2,IN1,IO1)
C                        unless LP21 = 0.
C
C       LP21 = Index of IN1 as a neighbor of IN2 after the
C              swap is performed unless IN1 and IN2 are
C              adjacent on input, in which case LP21 = 0.
C
C Module required by SWAP:  LSTPTR
C
C Intrinsic function called by SWAP:  ABS
C
C***********************************************************
C
      INTEGER LSTPTR
      INTEGER LP, LPH, LPSAV
C
C Local parameters:
C
C LP,LPH,LPSAV = LIST pointers
C
C
C Test for IN1 and IN2 adjacent.
C
      LP = LSTPTR(LEND(IN1),IN2,LIST,LPTR)
      IF (ABS(LIST(LP)) .EQ. IN2) THEN
        LP21 = 0
        RETURN
      ENDIF
C
C Delete IO2 as a neighbor of IO1.
C
      LP = LSTPTR(LEND(IO1),IN2,LIST,LPTR)
      LPH = LPTR(LP)
      LPTR(LP) = LPTR(LPH)
C
C If IO2 is the last neighbor of IO1, make IN2 the
C   last neighbor.
C
      IF (LEND(IO1) .EQ. LPH) LEND(IO1) = LP
C
C Insert IN2 as a neighbor of IN1 following IO1
C   using the hole created above.
C
      LP = LSTPTR(LEND(IN1),IO1,LIST,LPTR)
      LPSAV = LPTR(LP)
      LPTR(LP) = LPH
      LIST(LPH) = IN2
      LPTR(LPH) = LPSAV
C
C Delete IO1 as a neighbor of IO2.
C
      LP = LSTPTR(LEND(IO2),IN1,LIST,LPTR)
      LPH = LPTR(LP)
      LPTR(LP) = LPTR(LPH)
C
C If IO1 is the last neighbor of IO2, make IN1 the
C   last neighbor.
C
      IF (LEND(IO2) .EQ. LPH) LEND(IO2) = LP
C
C Insert IN1 as a neighbor of IN2 following IO2.
C
      LP = LSTPTR(LEND(IN2),IO2,LIST,LPTR)
      LPSAV = LPTR(LP)
      LPTR(LP) = LPH
      LIST(LPH) = IN1
      LPTR(LPH) = LPSAV
      LP21 = LPH
      RETURN
      END
      LOGICAL FUNCTION SWPTST (IN1,IN2,IO1,IO2,X,Y)
      INTEGER IN1, IN2, IO1, IO2
      DOUBLE PRECISION X(*), Y(*)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   09/01/88
C
C   This function applies the circumcircle test to a quadri-
C lateral defined by a pair of adjacent triangles.  The
C diagonal arc (shared triangle side) should be swapped for
C the other diagonl if and only if the fourth vertex is
C strictly interior to the circumcircle of one of the
C triangles (the decision is independent of the choice of
C triangle).  Equivalently, the diagonal is chosen to maxi-
C mize the smallest of the six interior angles over the two
C pairs of possible triangles (the decision is for no swap
C if the quadrilateral is not strictly convex).
C
C   When the four vertices are nearly cocircular (the
C neutral case), the preferred decision is no swap -- in
C order to avoid unnecessary swaps and, more important, to
C avoid cycling in Subroutine OPTIM which is called by
C DELNOD and EDGE.  Thus, a tolerance SWTOL (stored in
C SWPCOM by TRMESH or TRMSHR) is used to define 'nearness'
C to the neutral case.
C
C
C On input:
C
C       IN1,IN2,IO1,IO2 = Nodal indexes of the vertices of
C                         the quadrilateral.  IO1-IO2 is the
C                         triangulation arc (shared triangle
C                         side) to be replaced by IN1-IN2 if
C                         the decision is to swap.  The
C                         triples (IO1,IO2,IN1) and (IO2,
C                         IO1,IN2) must define triangles (be
C                         in counterclockwise order) on in-
C                         put.
C
C       X,Y = Arrays containing the nodal coordinates.
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       SWPTST = .TRUE. if and only if the arc connecting
C                IO1 and IO2 is to be replaced.
C
C Modules required by SWPTST:  None
C
C***********************************************************
C
      DOUBLE PRECISION DX11, DX12, DX22, DX21, DY11, DY12, DY22, DY21,
     .     SIN1, SIN2, COS1, COS2, SIN12, SWTOL
C
C Tolerance stored by TRMESH or TRMSHR.
C
      COMMON/SWPCOM/SWTOL
C
C Local parameters:
C
C DX11,DY11 = X,Y components of the vector IN1->IO1
C DX12,DY12 = X,Y components of the vector IN1->IO2
C DX22,DY22 = X,Y components of the vector IN2->IO2
C DX21,DY21 = X,Y components of the vector IN2->IO1
C SIN1 =      Cross product of the vectors IN1->IO1 and
C               IN1->IO2 -- proportional to sin(T1), where
C               T1 is the angle at IN1 formed by the vectors
C COS1 =      Inner product of the vectors IN1->IO1 and
C               IN1->IO2 -- proportional to cos(T1)
C SIN2 =      Cross product of the vectors IN2->IO2 and
C               IN2->IO1 -- proportional to sin(T2), where
C               T2 is the angle at IN2 formed by the vectors
C COS2 =      Inner product of the vectors IN2->IO2 and
C               IN2->IO1 -- proportional to cos(T2)
C SIN12 =     SIN1*COS2 + COS1*SIN2 -- proportional to
C               sin(T1+T2)
C
C
C Compute the vectors containing the angles T1 and T2.
C
      DX11 = X(IO1) - X(IN1)
      DX12 = X(IO2) - X(IN1)
      DX22 = X(IO2) - X(IN2)
      DX21 = X(IO1) - X(IN2)
C
      DY11 = Y(IO1) - Y(IN1)
      DY12 = Y(IO2) - Y(IN1)
      DY22 = Y(IO2) - Y(IN2)
      DY21 = Y(IO1) - Y(IN2)
C
C Compute inner products.
C
      COS1 = DX11*DX12 + DY11*DY12
      COS2 = DX22*DX21 + DY22*DY21
C
C The diagonals should be swapped iff (T1+T2) > 180
C   degrees.  The following two tests ensure numerical
C   stability:  the decision must be FALSE when both
C   angles are close to 0, and TRUE when both angles
C   are close to 180 degrees.
C
      IF (COS1 .GE. 0.  .AND.  COS2 .GE. 0.) GO TO 2
      IF (COS1 .LT. 0.  .AND.  COS2 .LT. 0.) GO TO 1
C
C Compute vector cross products (Z-components).
C
      SIN1 = DX11*DY12 - DX12*DY11
      SIN2 = DX22*DY21 - DX21*DY22
      SIN12 = SIN1*COS2 + COS1*SIN2
      IF (SIN12 .GE. -SWTOL) GO TO 2
C
C Swap.
C
    1 SWPTST = .TRUE.
      RETURN
C
C No swap.
C
    2 SWPTST = .FALSE.
      RETURN
      END
      SUBROUTINE TRFIND (NST,PX,PY,N,X,Y,LIST,LPTR,LEND, I1,
     .                   I2,I3)
      INTEGER NST, N, LIST(*), LPTR(*), LEND(N), I1, I2, I3
      DOUBLE PRECISION PX, PY, X(N), Y(N)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/28/98
C
C   This subroutine locates a point P relative to a triangu-
C lation created by Subroutine TRMESH or TRMSHR.  If P is
C contained in a triangle, the three vertex indexes are
C returned.  Otherwise, the indexes of the rightmost and
C leftmost visible boundary nodes are returned.
C
C
C On input:
C
C       NST = Index of a node at which TRFIND begins the
C             search.  Search time depends on the proximity
C             of this node to P.
C
C       PX,PY = X and y coordinates of the point P to be
C               located.
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       X,Y = Arrays of length N containing the coordinates
C             of the nodes in the triangulation.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       I1,I2,I3 = Nodal indexes, in counterclockwise order,
C                  of the vertices of a triangle containing
C                  P if P is contained in a triangle.  If P
C                  is not in the convex hull of the nodes,
C                  I1 indexes the rightmost visible boundary
C                  node, I2 indexes the leftmost visible
C                  boundary node, and I3 = 0.  Rightmost and
C                  leftmost are defined from the perspective
C                  of P, and a pair of points are visible
C                  from each other if and only if the line
C                  segment joining them intersects no trian-
C                  gulation arc.  If P and all of the nodes
C                  lie on a common line, then I1 = I2 = I3 =
C                  0 on output.
C
C Modules required by TRFIND:  JRAND, LEFT, LSTPTR, STORE
C
C Intrinsic function called by TRFIND:  ABS
C
C***********************************************************
C
      INTEGER JRAND, LSTPTR
      LOGICAL LEFT
      DOUBLE PRECISION STORE
      INTEGER IX, IY, IZ, LP, N0, N1, N1S, N2, N2S, N3, N4,
     .        NB, NF, NL, NP, NPP
      LOGICAL FRWRD
      DOUBLE PRECISION B1, B2, XA, XB, XC, XP, YA, YB, YC,
     .        YP
C
      SAVE    IX, IY, IZ
      DATA    IX/1/, IY/2/, IZ/3/
C
C Local parameters:
C
C B1,B2 =    Unnormalized barycentric coordinates of P with
C              respect to (N1,N2,N3)
C IX,IY,IZ = Integer seeds for JRAND
C LP =       LIST pointer
C N0,N1,N2 = Nodes in counterclockwise order defining a
C              cone (with vertex N0) containing P
C N1S,N2S =  Saved values of N1 and N2
C N3,N4 =    Nodes opposite N1->N2 and N2->N1, respectively
C NB =       Index of a boundary node -- first neighbor of
C              NF or last neighbor of NL in the boundary
C              traversal loops
C NF,NL =    First and last neighbors of N0, or first
C              (rightmost) and last (leftmost) nodes
C              visible from P when P is exterior to the
C              triangulation
C NP,NPP =   Indexes of boundary nodes used in the boundary
C              traversal loops
C XA,XB,XC = Dummy arguments for FRWRD
C YA,YB,YC = Dummy arguments for FRWRD
C XP,YP =    Local variables containing the components of P
C
C Statement function:
C
C FRWRD = TRUE iff C is forward of A->B
C              iff <A->B,A->C> .GE. 0.
C
      FRWRD(XA,YA,XB,YB,XC,YC) = (XB-XA)*(XC-XA) +
     .                           (YB-YA)*(YC-YA) .GE. 0.
C
C Initialize variables.
C
      XP = PX
      YP = PY
      N0 = NST
      IF (N0 .LT. 1  .OR.  N0 .GT. N)
     .  N0 = JRAND(N, IX,IY,IZ )
C
C Set NF and NL to the first and last neighbors of N0, and
C   initialize N1 = NF.
C
    1 LP = LEND(N0)
      NL = LIST(LP)
      LP = LPTR(LP)
      NF = LIST(LP)
      N1 = NF
C
C Find a pair of adjacent neighbors N1,N2 of N0 that define
C   a wedge containing P:  P LEFT N0->N1 and P RIGHT N0->N2.
C
      IF (NL .GT. 0) GO TO 2
C
C   N0 is a boundary node.  Test for P exterior.
C
      NL = -NL
      IF ( .NOT. LEFT(X(N0),Y(N0),X(NF),Y(NF),XP,YP) ) THEN
        NL = N0
        GO TO 9
      ENDIF
      IF ( .NOT. LEFT(X(NL),Y(NL),X(N0),Y(N0),XP,YP) ) THEN
        NB = NF
        NF = N0
        NP = NL
        NPP = N0
        GO TO 11
      ENDIF
      GO TO 3
C
C   N0 is an interior node.  Find N1.
C
    2 IF ( LEFT(X(N0),Y(N0),X(N1),Y(N1),XP,YP) ) GO TO 3
        LP = LPTR(LP)
        N1 = LIST(LP)
        IF (N1 .EQ. NL) GO TO 6
        GO TO 2
C
C   P is to the left of edge N0->N1.  Initialize N2 to the
C     next neighbor of N0.
C
    3 LP = LPTR(LP)
        N2 = ABS(LIST(LP))
        IF ( .NOT. LEFT(X(N0),Y(N0),X(N2),Y(N2),XP,YP) )
     .    GO TO 7
        N1 = N2
        IF (N1 .NE. NL) GO TO 3
      IF ( .NOT. LEFT(X(N0),Y(N0),X(NF),Y(NF),XP,YP) )
     .  GO TO 6
      IF (XP .EQ. X(N0) .AND. YP .EQ. Y(N0)) GO TO 5
C
C   P is left of or on edges N0->NB for all neighbors NB
C     of N0.
C   All points are collinear iff P is left of NB->N0 for
C     all neighbors NB of N0.  Search the neighbors of N0.
C     NOTE -- N1 = NL and LP points to NL.
C
    4 IF ( .NOT. LEFT(X(N1),Y(N1),X(N0),Y(N0),XP,YP) )
     .  GO TO 5
        LP = LPTR(LP)
        N1 = ABS(LIST(LP))
        IF (N1 .EQ. NL) GO TO 17
        GO TO 4
C
C   P is to the right of N1->N0, or P=N0.  Set N0 to N1 and
C     start over.
C
    5 N0 = N1
      GO TO 1
C
C   P is between edges N0->N1 and N0->NF.
C
    6 N2 = NF
C
C P is contained in the wedge defined by line segments
C   N0->N1 and N0->N2, where N1 is adjacent to N2.  Set
C   N3 to the node opposite N1->N2, and save N1 and N2 to
C   test for cycling.
C
    7 N3 = N0
      N1S = N1
      N2S = N2
C
C Top of edge hopping loop.  Test for termination.
C
    8 IF ( LEFT(X(N1),Y(N1),X(N2),Y(N2),XP,YP) ) THEN
C
C   P LEFT N1->N2 and hence P is in (N1,N2,N3) unless an
C     error resulted from floating point inaccuracy and
C     collinearity.  Compute the unnormalized barycentric
C     coordinates of P with respect to (N1,N2,N3).
C
        B1 = (X(N3)-X(N2))*(YP-Y(N2)) -
     .       (XP-X(N2))*(Y(N3)-Y(N2))
        B2 = (X(N1)-X(N3))*(YP-Y(N3)) -
     .       (XP-X(N3))*(Y(N1)-Y(N3))
        IF (STORE(B1+1.) .GE. 1.  .AND.
     .      STORE(B2+1.) .GE. 1.) GO TO 16
C
C   Restart with N0 randomly selected.
C
        N0 = JRAND(N, IX,IY,IZ )
        GO TO 1
      ENDIF
C
C   Set N4 to the neighbor of N2 which follows N1 (node
C     opposite N2->N1) unless N1->N2 is a boundary edge.
C
      LP = LSTPTR(LEND(N2),N1,LIST,LPTR)
      IF (LIST(LP) .LT. 0) THEN
        NF = N2
        NL = N1
        GO TO 9
      ENDIF
      LP = LPTR(LP)
      N4 = ABS(LIST(LP))
C
C   Select the new edge N1->N2 which intersects the line
C     segment N0-P, and set N3 to the node opposite N1->N2.
C
      IF ( LEFT(X(N0),Y(N0),X(N4),Y(N4),XP,YP) ) THEN
        N3 = N1
        N1 = N4
        N2S = N2
        IF (N1 .NE. N1S  .AND.  N1 .NE. N0) GO TO 8
      ELSE
        N3 = N2
        N2 = N4
        N1S = N1
        IF (N2 .NE. N2S  .AND.  N2 .NE. N0) GO TO 8
      ENDIF
C
C   The starting node N0 or edge N1-N2 was encountered
C     again, implying a cycle (infinite loop).  Restart
C     with N0 randomly selected.
C
      N0 = JRAND(N, IX,IY,IZ )
      GO TO 1
C
C Boundary traversal loops.  NL->NF is a boundary edge and
C   P RIGHT NL->NF.  Save NL and NF.

    9 NP = NL
      NPP = NF
C
C Find the first (rightmost) visible boundary node NF.  NB
C   is set to the first neighbor of NF, and NP is the last
C   neighbor.
C
   10 LP = LEND(NF)
      LP = LPTR(LP)
      NB = LIST(LP)
      IF ( .NOT. LEFT(X(NF),Y(NF),X(NB),Y(NB),XP,YP) )
     .  GO TO 12
C
C   P LEFT NF->NB and thus NB is not visible unless an error
C     resulted from floating point inaccuracy and collinear-
C     ity of the 4 points NP, NF, NB, and P.
C
   11 IF ( FRWRD(X(NF),Y(NF),X(NP),Y(NP),XP,YP)  .OR.
     .     FRWRD(X(NF),Y(NF),X(NP),Y(NP),X(NB),Y(NB)) ) THEN
        I1 = NF
        GO TO 13
      ENDIF
C
C   Bottom of loop.
C
   12 NP = NF
      NF = NB
      GO TO 10
C
C Find the last (leftmost) visible boundary node NL.  NB
C   is set to the last neighbor of NL, and NPP is the first
C   neighbor.
C
   13 LP = LEND(NL)
      NB = -LIST(LP)
      IF ( .NOT. LEFT(X(NB),Y(NB),X(NL),Y(NL),XP,YP) )
     .  GO TO 14
C
C   P LEFT NB->NL and thus NB is not visible unless an error
C     resulted from floating point inaccuracy and collinear-
C     ity of the 4 points P, NB, NL, and NPP.
C
      IF ( FRWRD(X(NL),Y(NL),X(NPP),Y(NPP),XP,YP)  .OR.
     .     FRWRD(X(NL),Y(NL),X(NPP),Y(NPP),X(NB),Y(NB)) )
     .  GO TO 15
C
C   Bottom of loop.
C
   14 NPP = NL
      NL = NB
      GO TO 13
C
C NL is the leftmost visible boundary node.
C
   15 I2 = NL
      I3 = 0
      RETURN
C
C P is in the triangle (N1,N2,N3).
C
   16 I1 = N1
      I2 = N2
      I3 = N3
      RETURN
C
C All points are collinear.
C
   17 I1 = 0
      I2 = 0
      I3 = 0
      RETURN
      END
      SUBROUTINE TRLIST (NCC,LCC,N,LIST,LPTR,LEND,NROW, NT,
     .                   LTRI,LCT,IER)
      INTEGER NCC, LCC(*), N, LIST(*), LPTR(*), LEND(N),
     .        NROW, NT, LTRI(NROW,*), LCT(*), IER
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   03/22/97
C
C   This subroutine converts a triangulation data structure
C from the linked list created by Subroutine TRMESH or
C TRMSHR to a triangle list.
C
C On input:
C
C       NCC = Number of constraints.  NCC .GE. 0.
C
C       LCC = List of constraint curve starting indexes (or
C             dummy array of length 1 if NCC = 0).  Refer to
C             Subroutine ADDCST.
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       LIST,LPTR,LEND = Linked list data structure defin-
C                        ing the triangulation.  Refer to
C                        Subroutine TRMESH.
C
C       NROW = Number of rows (entries per triangle) re-
C              served for the triangle list LTRI.  The value
C              must be 6 if only the vertex indexes and
C              neighboring triangle indexes are to be
C              stored, or 9 if arc indexes are also to be
C              assigned and stored.  Refer to LTRI.
C
C The above parameters are not altered by this routine.
C
C       LTRI = Integer array of length at least NROW*NT,
C              where NT is at most 2N-5.  (A sufficient
C              length is 12N if NROW=6 or 18N if NROW=9.)
C
C       LCT = Integer array of length NCC or dummy array of
C             length 1 if NCC = 0.
C
C On output:
C
C       NT = Number of triangles in the triangulation unless
C            IER .NE. 0, in which case NT = 0.  NT = 2N - NB
C            - 2, where NB is the number of boundary nodes.
C
C       LTRI = NROW by NT array whose J-th column contains
C              the vertex nodal indexes (first three rows),
C              neighboring triangle indexes (second three
C              rows), and, if NROW = 9, arc indexes (last
C              three rows) associated with triangle J for
C              J = 1,...,NT.  The vertices are ordered
C              counterclockwise with the first vertex taken
C              to be the one with smallest index.  Thus,
C              LTRI(2,J) and LTRI(3,J) are larger than
C              LTRI(1,J) and index adjacent neighbors of
C              node LTRI(1,J).  For I = 1,2,3, LTRI(I+3,J)
C              and LTRI(I+6,J) index the triangle and arc,
C              respectively, which are opposite (not shared
C              by) node LTRI(I,J), with LTRI(I+3,J) = 0 if
C              LTRI(I+6,J) indexes a boundary arc.  Vertex
C              indexes range from 1 to N, triangle indexes
C              from 0 to NT, and, if included, arc indexes
C              from 1 to NA = NT+N-1.  The triangles are or-
C              dered on first (smallest) vertex indexes,
C              except that the sets of constraint triangles
C              (triangles contained in the closure of a con-
C              straint region) follow the non-constraint
C              triangles.
C
C       LCT = Array of length NCC containing the triangle
C             index of the first triangle of constraint J in
C             LCT(J).  Thus, the number of non-constraint
C             triangles is LCT(1)-1, and constraint J con-
C             tains LCT(J+1)-LCT(J) triangles, where
C             LCT(NCC+1) = NT+1.
C
C       IER = Error indicator.
C             IER = 0 if no errors were encountered.
C             IER = 1 if NCC, N, NROW, or an LCC entry is
C                     outside its valid range on input.
C             IER = 2 if the triangulation data structure
C                     (LIST,LPTR,LEND) is invalid.  Note,
C                     however, that these arrays are not
C                     completely tested for validity.
C
C Modules required by TRLIST:  None
C
C Intrinsic function called by TRLIST:  ABS
C
C***********************************************************
C
      INTEGER I, I1, I2, I3, ISV, J, JLAST, KA, KN, KT, L,
     .        LCC1, LP, LP2, LPL, LPLN1, N1, N1ST, N2, N3,
     .        NM2, NN
      LOGICAL ARCS, CSTRI, PASS2
C
C Test for invalid input parameters and store the index
C   LCC1 of the first constraint node (if any).
C
      NN = N
      IF (NCC .LT. 0  .OR.  (NROW .NE. 6  .AND.
     .    NROW .NE. 9)) GO TO 12
      LCC1 = NN+1
      IF (NCC .EQ. 0) THEN
        IF (NN .LT. 3) GO TO 12
      ELSE
        DO 1 I = NCC,1,-1
          IF (LCC1-LCC(I) .LT. 3) GO TO 12
          LCC1 = LCC(I)
    1     CONTINUE
        IF (LCC1 .LT. 1) GO TO 12
      ENDIF
C
C Initialize parameters for loop on triangles KT = (N1,N2,
C   N3), where N1 < N2 and N1 < N3.  This requires two
C   passes through the nodes with all non-constraint
C   triangles stored on the first pass, and the constraint
C   triangles stored on the second.
C
C   ARCS = TRUE iff arc indexes are to be stored.
C   KA,KT = Numbers of currently stored arcs and triangles.
C   N1ST = Starting index for the loop on nodes (N1ST = 1 on
C            pass 1, and N1ST = LCC1 on pass 2).
C   NM2 = Upper bound on candidates for N1.
C   PASS2 = TRUE iff constraint triangles are to be stored.
C
      ARCS = NROW .EQ. 9
      KA = 0
      KT = 0
      N1ST = 1
      NM2 = NN-2
      PASS2 = .FALSE.
C
C Loop on nodes N1:  J = constraint containing N1,
C                    JLAST = last node in constraint J.
C
    2 J = 0
      JLAST = LCC1 - 1
      DO 11 N1 = N1ST,NM2
        IF (N1 .GT. JLAST) THEN
C
C N1 is the first node in constraint J+1.  Update J and
C   JLAST, and store the first constraint triangle index
C   if in pass 2.
C
          J = J + 1
          IF (J .LT. NCC) THEN
            JLAST = LCC(J+1) - 1
          ELSE
            JLAST = NN
          ENDIF
          IF (PASS2) LCT(J) = KT + 1
        ENDIF
C
C Loop on pairs of adjacent neighbors (N2,N3).  LPLN1 points
C   to the last neighbor of N1, and LP2 points to N2.
C
        LPLN1 = LEND(N1)
        LP2 = LPLN1
    3     LP2 = LPTR(LP2)
          N2 = LIST(LP2)
          LP = LPTR(LP2)
          N3 = ABS(LIST(LP))
          IF (N2 .LT. N1  .OR.  N3 .LT. N1) GO TO 10
C
C (N1,N2,N3) is a constraint triangle iff the three nodes
C   are in the same constraint and N2 < N3.  Bypass con-
C   straint triangles on pass 1 and non-constraint triangles
C   on pass 2.
C
          CSTRI = N1 .GE. LCC1  .AND.  N2 .LT. N3  .AND.
     .            N3 .LE. JLAST
          IF ((CSTRI  .AND.  .NOT. PASS2)  .OR.
     .        (.NOT. CSTRI  .AND.  PASS2)) GO TO 10
C
C Add a new triangle KT = (N1,N2,N3).
C
          KT = KT + 1
          LTRI(1,KT) = N1
          LTRI(2,KT) = N2
          LTRI(3,KT) = N3
C
C Loop on triangle sides (I1,I2) with neighboring triangles
C   KN = (I1,I2,I3).
C
          DO 9 I = 1,3
            IF (I .EQ. 1) THEN
              I1 = N3
              I2 = N2
            ELSEIF (I .EQ. 2) THEN
              I1 = N1
              I2 = N3
            ELSE
              I1 = N2
              I2 = N1
            ENDIF
C
C Set I3 to the neighbor of I1 which follows I2 unless
C   I2->I1 is a boundary arc.
C
            LPL = LEND(I1)
            LP = LPTR(LPL)
    4       IF (LIST(LP) .EQ. I2) GO TO 5
              LP = LPTR(LP)
              IF (LP .NE. LPL) GO TO 4
C
C   I2 is the last neighbor of I1 unless the data structure
C     is invalid.  Bypass the search for a neighboring
C     triangle if I2->I1 is a boundary arc.
C
            IF (ABS(LIST(LP)) .NE. I2) GO TO 13
            KN = 0
            IF (LIST(LP) .LT. 0) GO TO 8
C
C   I2->I1 is not a boundary arc, and LP points to I2 as
C     a neighbor of I1.
C
    5       LP = LPTR(LP)
            I3 = ABS(LIST(LP))
C
C Find L such that LTRI(L,KN) = I3 (not used if KN > KT),
C   and permute the vertex indexes of KN so that I1 is
C   smallest.
C
            IF (I1 .LT. I2  .AND.  I1 .LT. I3) THEN
              L = 3
            ELSEIF (I2 .LT. I3) THEN
              L = 2
              ISV = I1
              I1 = I2
              I2 = I3
              I3 = ISV
            ELSE
              L = 1
              ISV = I1
              I1 = I3
              I3 = I2
              I2 = ISV
            ENDIF
C
C Test for KN > KT (triangle index not yet assigned).
C
            IF (I1 .GT. N1  .AND.  .NOT. PASS2) GO TO 9
C
C Find KN, if it exists, by searching the triangle list in
C   reverse order.
C
            DO 6 KN = KT-1,1,-1
              IF (LTRI(1,KN) .EQ. I1  .AND.  LTRI(2,KN) .EQ.
     .            I2  .AND.  LTRI(3,KN) .EQ. I3) GO TO 7
    6         CONTINUE
            GO TO 9
C
C Store KT as a neighbor of KN.
C
    7       LTRI(L+3,KN) = KT
C
C Store KN as a neighbor of KT, and add a new arc KA.
C
    8       LTRI(I+3,KT) = KN
            IF (ARCS) THEN
              KA = KA + 1
              LTRI(I+6,KT) = KA
              IF (KN .NE. 0) LTRI(L+6,KN) = KA
            ENDIF
    9       CONTINUE
C
C Bottom of loop on triangles.
C
   10     IF (LP2 .NE. LPLN1) GO TO 3
   11     CONTINUE
C
C Bottom of loop on nodes.
C
      IF (.NOT. PASS2  .AND.  NCC .GT. 0) THEN
        PASS2 = .TRUE.
        N1ST = LCC1
        GO TO 2
      ENDIF
C
C No errors encountered.
C
      NT = KT
      IER = 0
      RETURN
C
C Invalid input parameter.
C
   12 NT = 0
      IER = 1
      RETURN
C
C Invalid triangulation data structure:  I1 is a neighbor of
C   I2, but I2 is not a neighbor of I1.
C
   13 NT = 0
      IER = 2
      RETURN
      END
      SUBROUTINE TRLPRT (NCC,LCT,N,X,Y,NROW,NT,LTRI,LOUT,
     .                   PRNTX)
      INTEGER NCC, LCT(*), N, NROW, NT, LTRI(NROW,NT),
     .        LOUT
      LOGICAL PRNTX
      DOUBLE PRECISION X(N), Y(N)
C
C***********************************************************
C
C                                               From TRLPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/02/98
C
C   Given a triangulation of a set of points in the plane,
C this subroutine prints the triangle list created by
C Subroutine TRLIST and, optionally, the nodal coordinates
C on logical unit LOUT.  The numbers of boundary nodes,
C triangles, and arcs, and the constraint region triangle
C indexes, if any, are also printed.
C
C   All parameters other than LOUT and PRNTX should be
C unaltered from their values on output from TRLIST.
C
C
C On input:
C
C       NCC = Number of constraints.
C
C       LCT = List of constraint triangle starting indexes
C             (or dummy array of length 1 if NCC = 0).
C
C       N = Number of nodes in the triangulation.
C           3 .LE. N .LE. 9999.
C
C       X,Y = Arrays of length N containing the coordinates
C             of the nodes in the triangulation -- not used
C             unless PRNTX = TRUE.
C
C       NROW = Number of rows (entries per triangle) re-
C              served for the triangle list LTRI.  The value
C              must be 6 if only the vertex indexes and
C              neighboring triangle indexes are stored, or 9
C              if arc indexes are also stored.
C
C       NT = Number of triangles in the triangulation.
C            1 .LE. NT .LE. 9999.
C
C       LTRI = NROW by NT array whose J-th column contains
C              the vertex nodal indexes (first three rows),
C              neighboring triangle indexes (second three
C              rows), and, if NROW = 9, arc indexes (last
C              three rows) associated with triangle J for
C              J = 1,...,NT.
C
C       LOUT = Logical unit number for output.  0 .LE. LOUT
C              .LE. 99.  Output is printed on unit 6 if LOUT
C              is outside its valid range on input.
C
C       PRNTX = Logical variable with value TRUE if and only
C               if X and Y are to be printed (to 6 decimal
C               places).
C
C None of the parameters are altered by this routine.
C
C Modules required by TRLPRT:  None
C
C***********************************************************
C
      INTEGER I, K, LUN, NA, NB, NL, NLMAX, NMAX
      DATA    NMAX/9999/,  NLMAX/60/
C
C Local parameters:
C
C   I = DO-loop, nodal index, and row index for LTRI
C   K = DO-loop and triangle index
C   LUN = Logical unit number for output
C   NA = Number of triangulation arcs
C   NB = Number of boundary nodes
C   NL = Number of lines printed on the current page
C   NLMAX = Maximum number of print lines per page
C   NMAX = Maximum value of N and NT (4-digit format)
C
      LUN = LOUT
      IF (LUN .LT. 0  .OR.  LUN .GT. 99) LUN = 6
C
C Print a heading and test for invalid input.
C
      WRITE (LUN,100)
      NL = 1
      IF (N .LT. 3  .OR.  N .GT. NMAX  .OR.
     .    (NROW .NE. 6  .AND.  NROW .NE. 9)  .OR.
     .    NT .LT. 1  .OR.  NT .GT. NMAX) THEN
C
C Print an error message and bypass the loops.
C
        WRITE (LUN,110) N, NROW, NT
        GO TO 3
      ENDIF
      IF (PRNTX) THEN
C
C Print X and Y.
C
        WRITE (LUN,101)
        NL = 6
        DO 1 I = 1,N
          IF (NL .GE. NLMAX) THEN
            WRITE (LUN,106)
            NL = 0
          ENDIF
          WRITE (LUN,102) I, X(I), Y(I)
          NL = NL + 1
    1     CONTINUE
      ENDIF
C
C Print the triangulation LTRI.
C
      IF (NL .GT. NLMAX/2) THEN
        WRITE (LUN,106)
        NL = 0
      ENDIF
      IF (NROW .EQ. 6) THEN
        WRITE (LUN,103)
      ELSE
        WRITE (LUN,104)
      ENDIF
      NL = NL + 5
      DO 2 K = 1,NT
        IF (NL .GE. NLMAX) THEN
          WRITE (LUN,106)
          NL = 0
        ENDIF
        WRITE (LUN,105) K, (LTRI(I,K), I = 1,NROW)
        NL = NL + 1
    2   CONTINUE
C
C Print NB, NA, and NT (boundary nodes, arcs, and
C   triangles).
C
      NB = 2*N - NT - 2
      NA = NT + N - 1
      IF (NL .GT. NLMAX-6) WRITE (LUN,106)
      WRITE (LUN,107) NB, NA, NT
C
C Print NCC and LCT.
C
    3 WRITE (LUN,108) NCC
      IF (NCC .GT. 0) WRITE (LUN,109) (LCT(I), I = 1,NCC)
      RETURN
C
C Print formats:
C
  100 FORMAT (///,24X,'TRIPACK (TRLIST) Output')
  101 FORMAT (//16X,'Node',7X,'X(Node)',10X,'Y(Node)'//)
  102 FORMAT (16X,I4,2E17.6)
  103 FORMAT (//1X,'Triangle',8X,'Vertices',12X,'Neighbors'/
     .        4X,'KT',7X,'N1',5X,'N2',5X,'N3',4X,'KT1',4X,
     .        'KT2',4X,'KT3'/)
  104 FORMAT (//1X,'Triangle',8X,'Vertices',12X,'Neighbors',
     .        14X,'Arcs'/
     .        4X,'KT',7X,'N1',5X,'N2',5X,'N3',4X,'KT1',4X,
     .        'KT2',4X,'KT3',4X,'KA1',4X,'KA2',4X,'KA3'/)
  105 FORMAT (2X,I4,2X,6(3X,I4),3(2X,I5))
  106 FORMAT (///)
  107 FORMAT (/1X,'NB = ',I4,' Boundary Nodes',5X,
     .        'NA = ',I5,' Arcs',5X,'NT = ',I5,
     .        ' Triangles')
  108 FORMAT (/1X,'NCC =',I3,' Constraint Curves')
  109 FORMAT (1X,9X,14I5)
  110 FORMAT (//1X,10X,'*** Invalid Parameter:  N =',I5,
     .        ', NROW =',I5,', NT =',I5,' ***')
      END
      SUBROUTINE TRMESH (N,X,Y, LIST,LPTR,LEND,LNEW,NEAR,
     .                   NEXT,DIST,IER)
      INTEGER N, LIST(*), LPTR(*), LEND(N), LNEW, NEAR(N),
     .        NEXT(N), IER
      DOUBLE PRECISION X(N), Y(N), DIST(N)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/28/98
C
C   This subroutine creates a Delaunay triangulation of a
C set of N arbitrarily distributed points in the plane re-
C ferred to as nodes.  The Delaunay triangulation is defined
C as a set of triangles with the following five properties:
C
C  1)  The triangle vertices are nodes.
C  2)  No triangle contains a node other than its vertices.
C  3)  The interiors of the triangles are pairwise disjoint.
C  4)  The union of triangles is the convex hull of the set
C        of nodes (the smallest convex set which contains
C        the nodes).
C  5)  The interior of the circumcircle of each triangle
C        contains no node.
C
C The first four properties define a triangulation, and the
C last property results in a triangulation which is as close
C as possible to equiangular in a certain sense and which is
C uniquely defined unless four or more nodes lie on a common
C circle.  This property makes the triangulation well-suited
C for solving closest point problems and for triangle-based
C interpolation.
C
C   The triangulation can be generalized to a constrained
C Delaunay triangulation by a call to Subroutine ADDCST.
C This allows for user-specified boundaries defining a non-
C convex and/or multiply connected region.
C
C   The algorithm for constructing the triangulation has
C expected time complexity O(N*log(N)) for most nodal dis-
C tributions.  Also, since the algorithm proceeds by adding
C nodes incrementally, the triangulation may be updated with
C the addition (or deletion) of a node very efficiently.
C The adjacency information representing the triangulation
C is stored as a linked list requiring approximately 13N
C storage locations.
C
C
C   The following is a list of the software package modules
C which a user may wish to call directly:
C
C  ADDCST - Generalizes the Delaunay triangulation to allow
C             for user-specified constraints.
C
C  ADDNOD - Updates the triangulation by appending or
C             inserting a new node.
C
C  AREAP  - Computes the area bounded by a closed polygonal
C             curve such as the boundary of the triangula-
C             tion or of a constraint region.
C
C  BNODES - Returns an array containing the indexes of the
C             boundary nodes in counterclockwise order.
C             Counts of boundary nodes, triangles, and arcs
C             are also returned.
C
C  CIRCUM - Computes the area, circumcenter, circumradius,
C             and, optionally, the aspect ratio of a trian-
C             gle defined by user-specified vertices.
C
C  DELARC - Deletes a boundary arc from the triangulation.
C
C  DELNOD - Updates the triangulation with the deletion of a
C             node.
C
C  EDGE   - Forces a pair of nodes to be connected by an arc
C             in the triangulation.
C
C  GETNP  - Determines the ordered sequence of L closest
C             nodes to a given node, along with the associ-
C             ated distances.  The distance between nodes is
C             taken to be the length of the shortest connec-
C             ting path which intersects no constraint
C             region.
C
C  INTSEC - Determines whether or not an arbitrary pair of
C             line segments share a common point.
C
C  JRAND  - Generates a uniformly distributed pseudo-random
C             integer.
C
C  LEFT   - Locates a point relative to a line.
C
C  NEARND - Returns the index of the nearest node to an
C             arbitrary point, along with its squared
C             distance.
C
C  STORE  - Forces a value to be stored in main memory so
C             that the precision of floating point numbers
C             in memory locations rather than registers is
C             computed.
C
C  TRLIST - Converts the triangulation data structure to a
C             triangle list more suitable for use in a fin-
C             ite element code.
C
C  TRLPRT - Prints the triangle list created by Subroutine
C             TRLIST.
C
C  TRMESH - Creates a Delaunay triangulation of a set of
C             nodes.
C
C  TRMSHR - Creates a Delaunay triangulation (more effici-
C             ently than TRMESH) of a set of nodes lying at
C             the vertices of a (possibly skewed) rectangu-
C             lar grid.
C
C  TRPLOT - Creates a level-2 Encapsulated Postscript (EPS)
C             file containing a triangulation plot.
C
C  TRPRNT - Prints the triangulation data structure and,
C             optionally, the nodal coordinates.
C
C
C On input:
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       X,Y = Arrays of length N containing the Cartesian
C             coordinates of the nodes.  (X(K),Y(K)) is re-
C             ferred to as node K, and K is referred to as
C             a nodal index.  The first three nodes must not
C             be collinear.
C
C The above parameters are not altered by this routine.
C
C       LIST,LPTR = Arrays of length at least 6N-12.
C
C       LEND = Array of length at least N.
C
C       NEAR,NEXT,DIST = Work space arrays of length at
C                        least N.  The space is used to
C                        efficiently determine the nearest
C                        triangulation node to each un-
C                        processed node for use by ADDNOD.
C
C On output:
C
C       LIST = Set of nodal indexes which, along with LPTR,
C              LEND, and LNEW, define the triangulation as a
C              set of N adjacency lists -- counterclockwise-
C              ordered sequences of neighboring nodes such
C              that the first and last neighbors of a bound-
C              ary node are boundary nodes (the first neigh-
C              bor of an interior node is arbitrary).  In
C              order to distinguish between interior and
C              boundary nodes, the last neighbor of each
C              boundary node is represented by the negative
C              of its index.
C
C       LPTR = Set of pointers (LIST indexes) in one-to-one
C              correspondence with the elements of LIST.
C              LIST(LPTR(I)) indexes the node which follows
C              LIST(I) in cyclical counterclockwise order
C              (the first neighbor follows the last neigh-
C              bor).
C
C       LEND = Set of pointers to adjacency lists.  LEND(K)
C              points to the last neighbor of node K for
C              K = 1,...,N.  Thus, LIST(LEND(K)) < 0 if and
C              only if K is a boundary node.
C
C       LNEW = Pointer to the first empty location in LIST
C              and LPTR (list length plus one).  LIST, LPTR,
C              LEND, and LNEW are not altered if IER < 0,
C              and are incomplete if IER > 0.
C
C       NEAR,NEXT,DIST = Garbage.
C
C       IER = Error indicator:
C             IER =  0 if no errors were encountered.
C             IER = -1 if N < 3 on input.
C             IER = -2 if the first three nodes are
C                      collinear.
C             IER = -4 if an error flag was returned by a
C                      call to SWAP in ADDNOD.  This is an
C                      internal error and should be reported
C                      to the programmer.
C             IER =  L if nodes L and M coincide for some
C                      M > L.  The linked list represents
C                      a triangulation of nodes 1 to M-1
C                      in this case.
C
C Modules required by TRMESH:  ADDNOD, BDYADD, INSERT,
C                                INTADD, JRAND, LEFT,
C                                LSTPTR, STORE, SWAP,
C                                SWPTST, TRFIND
C
C Intrinsic function called by TRMESH:  ABS
C
C***********************************************************
C
      LOGICAL LEFT
      DOUBLE PRECISION STORE
      INTEGER I, I0, J, K, KM1, LCC(1), LP, LPL, NCC, NEXTI,
     .        NN
      DOUBLE PRECISION D, D1, D2, D3, EPS, SWTOL
      COMMON/SWPCOM/SWTOL
C
C Local parameters:
C
C D =        Squared distance from node K to node I
C D1,D2,D3 = Squared distances from node K to nodes 1, 2,
C              and 3, respectively
C EPS =      Half the machine precision
C I,J =      Nodal indexes
C I0 =       Index of the node preceding I in a sequence of
C              unprocessed nodes:  I = NEXT(I0)
C K =        Index of node to be added and DO-loop index:
C              K > 3
C KM1 =      K-1
C LCC(1) =   Dummy array
C LP =       LIST index (pointer) of a neighbor of K
C LPL =      Pointer to the last neighbor of K
C NCC =      Number of constraint curves
C NEXTI =    NEXT(I)
C NN =       Local copy of N
C SWTOL =    Tolerance for function SWPTST
C
      NN = N
      IF (NN .LT. 3) THEN
        IER = -1
        RETURN
      ENDIF
C
C Compute a tolerance for function SWPTST:  SWTOL = 10*
C   (machine precision)
C
      EPS = 1.
    1 EPS = EPS/2.
        SWTOL = STORE(EPS + 1.)
        IF (SWTOL .GT. 1.) GO TO 1
      SWTOL = EPS*20.
C
C Store the first triangle in the linked list.
C
      IF ( .NOT. LEFT(X(1),Y(1),X(2),Y(2),X(3),Y(3)) ) THEN
C
C   The initial triangle is (3,2,1) = (2,1,3) = (1,3,2).
C
        LIST(1) = 3
        LPTR(1) = 2
        LIST(2) = -2
        LPTR(2) = 1
        LEND(1) = 2
C
        LIST(3) = 1
        LPTR(3) = 4
        LIST(4) = -3
        LPTR(4) = 3
        LEND(2) = 4
C
        LIST(5) = 2
        LPTR(5) = 6
        LIST(6) = -1
        LPTR(6) = 5
        LEND(3) = 6
C
      ELSEIF ( .NOT. LEFT(X(2),Y(2),X(1),Y(1),X(3),Y(3)) )
     .       THEN
C
C   The initial triangle is (1,2,3).
C
        LIST(1) = 2
        LPTR(1) = 2
        LIST(2) = -3
        LPTR(2) = 1
        LEND(1) = 2
C
        LIST(3) = 3
        LPTR(3) = 4
        LIST(4) = -1
        LPTR(4) = 3
        LEND(2) = 4
C
        LIST(5) = 1
        LPTR(5) = 6
        LIST(6) = -2
        LPTR(6) = 5
        LEND(3) = 6
C
      ELSE
C
C   The first three nodes are collinear.
C
        IER = -2
        RETURN
      ENDIF
C
C Initialize LNEW and test for N = 3.
C
      LNEW = 7
      IF (NN .EQ. 3) THEN
        IER = 0
        RETURN
      ENDIF
C
C A nearest-node data structure (NEAR, NEXT, and DIST) is
C   used to obtain an expected-time (N*log(N)) incremental
C   algorithm by enabling constant search time for locating
C   each new node in the triangulation.
C
C For each unprocessed node K, NEAR(K) is the index of the
C   triangulation node closest to K (used as the starting
C   point for the search in Subroutine TRFIND) and DIST(K)
C   is an increasing function of the distance between nodes
C   K and NEAR(K).
C
C Since it is necessary to efficiently find the subset of
C   unprocessed nodes associated with each triangulation
C   node J (those that have J as their NEAR entries), the
C   subsets are stored in NEAR and NEXT as follows:  for
C   each node J in the triangulation, I = NEAR(J) is the
C   first unprocessed node in J's set (with I = 0 if the
C   set is empty), L = NEXT(I) (if I > 0) is the second,
C   NEXT(L) (if L > 0) is the third, etc.  The nodes in each
C   set are initially ordered by increasing indexes (which
C   maximizes efficiency) but that ordering is not main-
C   tained as the data structure is updated.
C
C Initialize the data structure for the single triangle.
C
      NEAR(1) = 0
      NEAR(2) = 0
      NEAR(3) = 0
      DO 2 K = NN,4,-1
        D1 = (X(K)-X(1))**2 + (Y(K)-Y(1))**2
        D2 = (X(K)-X(2))**2 + (Y(K)-Y(2))**2
        D3 = (X(K)-X(3))**2 + (Y(K)-Y(3))**2
        IF (D1 .LE. D2  .AND.  D1 .LE. D3) THEN
          NEAR(K) = 1
          DIST(K) = D1
          NEXT(K) = NEAR(1)
          NEAR(1) = K
        ELSEIF (D2 .LE. D1  .AND.  D2 .LE. D3) THEN
          NEAR(K) = 2
          DIST(K) = D2
          NEXT(K) = NEAR(2)
          NEAR(2) = K
        ELSE
          NEAR(K) = 3
          DIST(K) = D3
          NEXT(K) = NEAR(3)
          NEAR(3) = K
        ENDIF
    2   CONTINUE
C
C Add the remaining nodes.  Parameters for ADDNOD are as
C   follows:
C
C   K = Index of the node to be added.
C   NEAR(K) = Index of the starting node for the search in
C             TRFIND.
C   NCC = Number of constraint curves.
C   LCC = Dummy array (since NCC = 0).
C   KM1 = Number of nodes in the triangulation.
C
      NCC = 0
      DO 7 K = 4,NN
        KM1 = K-1
        CALL ADDNOD (K,X(K),Y(K),NEAR(K),NCC, LCC,KM1,X,Y,
     .               LIST,LPTR,LEND,LNEW, IER)
        IF (IER .NE. 0) RETURN
C
C Remove K from the set of unprocessed nodes associated
C   with NEAR(K).
C
        I = NEAR(K)
        IF (NEAR(I) .EQ. K) THEN
          NEAR(I) = NEXT(K)
        ELSE
          I = NEAR(I)
    3     I0 = I
            I = NEXT(I0)
            IF (I .NE. K) GO TO 3
          NEXT(I0) = NEXT(K)
        ENDIF
        NEAR(K) = 0
C
C Loop on neighbors J of node K.
C
        LPL = LEND(K)
        LP = LPL
    4   LP = LPTR(LP)
          J = ABS(LIST(LP))
C
C Loop on elements I in the sequence of unprocessed nodes
C   associated with J:  K is a candidate for replacing J
C   as the nearest triangulation node to I.  The next value
C   of I in the sequence, NEXT(I), must be saved before I
C   is moved because it is altered by adding I to K's set.
C
          I = NEAR(J)
    5     IF (I .EQ. 0) GO TO 6
          NEXTI = NEXT(I)
C
C Test for the distance from I to K less than the distance
C   from I to J.
C
          D = (X(K)-X(I))**2 + (Y(K)-Y(I))**2
          IF (D .LT. DIST(I)) THEN
C
C Replace J by K as the nearest triangulation node to I:
C   update NEAR(I) and DIST(I), and remove I from J's set
C   of unprocessed nodes and add it to K's set.
C
            NEAR(I) = K
            DIST(I) = D
            IF (I .EQ. NEAR(J)) THEN
              NEAR(J) = NEXTI
            ELSE
              NEXT(I0) = NEXTI
            ENDIF
            NEXT(I) = NEAR(K)
            NEAR(K) = I
          ELSE
            I0 = I
          ENDIF
C
C Bottom of loop on I.
C
          I = NEXTI
          GO TO 5
C
C Bottom of loop on neighbors J.
C
    6     IF (LP .NE. LPL) GO TO 4
    7   CONTINUE
      RETURN
      END
      SUBROUTINE TRMSHR (N,NX,X,Y, NIT, LIST,LPTR,LEND,LNEW,
     .                   IER)
      INTEGER  N, NX, NIT, LIST(*), LPTR(*), LEND(N), LNEW,
     .         IER
      DOUBLE PRECISION  X(N), Y(N)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/27/98
C
C   This subroutine creates a Delaunay triangulation of a
C set of N nodes in the plane, where the nodes are the vert-
C ices of an NX by NY skewed rectangular grid with the
C natural ordering.  Thus, N = NX*NY, and the nodes are
C ordered from left to right beginning at the top row so
C that adjacent nodes have indexes which differ by 1 in the
C x-direction and by NX in the y-direction.  A skewed rec-
C tangular grid is defined as one in which each grid cell is
C a strictly convex quadrilateral (and is thus the convex
C hull of its four vertices).  Equivalently, any transfor-
C mation from a rectangle to a grid cell which is bilinear
C in both components has an invertible Jacobian.
C
C   If the nodes are not distributed and ordered as defined
C above, Subroutine TRMESH must be called in place of this
C routine.  Refer to Subroutine ADDCST for the treatment of
C constraints.
C
C   The first phase of the algorithm consists of construc-
C ting a triangulation by choosing a diagonal arc in each
C grid cell.  If NIT = 0, all diagonals connect lower left
C to upper right corners and no error checking or additional
C computation is performed.  Otherwise, each diagonal arc is
C chosen to be locally optimal, and boundary arcs are added
C where necessary in order to cover the convex hull of the
C nodes.  (This is the first iteration.)  If NIT > 1 and no
C error was detected, the triangulation is then optimized by
C a sequence of up to NIT-1 iterations in which interior
C arcs of the triangulation are tested and swapped if appro-
C priate.  The algorithm terminates when an iteration
C results in no swaps and/or when the allowable number of
C iterations has been performed.  NIT = 0 is sufficient to
C produce a Delaunay triangulation if the original grid is
C actually rectangular, and NIT = 1 is sufficient if it is
C close to rectangular.  Note, however, that the ordering
C and distribution of nodes is not checked for validity in
C the case NIT = 0, and the triangulation will not be valid
C unless the rectangular grid covers the convex hull of the
C nodes.
C
C
C On input:
C
C       N = Number of nodes in the grid.  N = NX*NY for some
C           NY .GE. 2.
C
C       NX = Number of grid points in the x-direction.  NX
C            .GE. 2.
C
C       X,Y = Arrays of length N containing coordinates of
C             the nodes with the ordering and distribution
C             defined in the header comments above.
C             (X(K),Y(K)) is referred to as node K.
C
C The above parameters are not altered by this routine.
C
C       NIT = Nonnegative integer specifying the maximum
C             number of iterations to be employed.  Refer
C             to the header comments above.
C
C       LIST,LPTR = Arrays of length at least 6N-12.
C
C       LEND = Array of length at least N.
C
C On output:
C
C       NIT = Number of iterations employed.
C
C       LIST,LPTR,LEND,LNEW = Data structure defining the
C                             triangulation.  Refer to Sub-
C                             routine TRMESH.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = K if the grid element with upper left
C                     corner at node K is not a strictly
C                     convex quadrilateral.  The algorithm
C                     is terminated when the first such
C                     occurrence is detected.  Note that
C                     this test is not performed if NIT = 0
C                     on input.
C             IER = -1 if N, NX, or NIT is outside its valid
C                      range on input.
C             IER = -2 if NIT > 1 on input, and the optimi-
C                      zation loop failed to converge within
C                      the allowable number of iterations.
C                      The triangulation is valid but not
C                      optimal in this case.
C
C Modules required by TRMSHR:  INSERT, LEFT, LSTPTR, NBCNT,
C                                STORE, SWAP, SWPTST
C
C Intrinsic function called by TRMSHR:  ABS
C
C***********************************************************
C
      INTEGER LSTPTR, NBCNT
      LOGICAL LEFT, SWPTST
      DOUBLE PRECISION STORE
      INTEGER I, ITER, J, K, KP1, LP, LPF, LPK, LPL, LPP,
     .        M1, M2, M3, M4, MAXIT, N0, N1, N2, N3, N4, NI,
     .        NJ, NM1, NN, NNB
      LOGICAL TST
      DOUBLE PRECISION EPS, SWTOL
      COMMON/SWPCOM/SWTOL
C
C Store local variables and test for errors in input
C   parameters.
C
      NI = NX
      NJ = N/NI
      NN = NI*NJ
      MAXIT = NIT
      NIT = 0
      IF (N .NE. NN  .OR.  NJ .LT. 2  .OR.  NI .LT. 2  .OR.
     .    MAXIT .LT. 0) THEN
        IER = -1
        RETURN
      ENDIF
      IER = 0
C
C Compute a tolerance for function SWPTST:  SWTOL = 10*
C   (machine precision)
C
      EPS = 1.
    1 EPS = EPS/2.
        SWTOL = STORE(EPS + 1.)
        IF (SWTOL .GT. 1.) GO TO 1
      SWTOL = EPS*20.
C
C Loop on grid points (I,J) corresponding to nodes K =
C   (J-1)*NI + I.  TST = TRUE iff diagonals are to be
C   chosen by the swap test.  M1, M2, M3, and M4 are the
C   slopes (-1, 0, or 1) of the diagonals in quadrants 1
C   to 4 (counterclockwise beginning with the upper right)
C   for a coordinate system with origin at node K.
C
      TST = MAXIT .GT. 0
      M1 = 0
      M4 = 0
      LP = 0
      KP1 = 1
      DO 6 J = 1,NJ
        DO 5 I = 1,NI
          M2 = M1
          M3 = M4
          K = KP1
          KP1 = K + 1
          LPF = LP + 1
          IF (J .EQ. NJ  .AND.  I .NE. NI) GO TO 2
          IF (I .NE. 1) THEN
            IF (J .NE. 1) THEN
C
C   K is not in the top row, leftmost column, or bottom row
C     (unless K is the lower right corner).  Take the first
C     neighbor to be the node above K.
C
              LP = LP + 1
              LIST(LP) = K - NI
              LPTR(LP) = LP + 1
              IF (M2 .LE. 0) THEN
                LP = LP + 1
                LIST(LP) = K - 1 - NI
                LPTR(LP) = LP + 1
              ENDIF
            ENDIF
C
C   K is not in the leftmost column.  The next (or first)
C     neighbor is to the left of K.
C
            LP = LP + 1
            LIST(LP) = K - 1
            LPTR(LP) = LP + 1
            IF (J .EQ. NJ) GO TO 3
            IF (M3 .GE. 0) THEN
              LP = LP + 1
              LIST(LP) = K - 1 + NI
              LPTR(LP) = LP + 1
            ENDIF
          ENDIF
C
C   K is not in the bottom row.  The next (or first)
C     neighbor is below K.
C
          LP = LP + 1
          LIST(LP) = K + NI
          LPTR(LP) = LP + 1
C
C   Test for a negative diagonal in quadrant 4 unless K is
C     in the rightmost column.  The quadrilateral associated
C     with the quadrant is tested for strict convexity un-
C     less NIT = 0 on input.
C
          IF (I .EQ. NI) GO TO 3
          M4 = 1
          IF (.NOT. TST) GO TO 2
          IF ( LEFT(X(KP1),Y(KP1),X(K+NI),Y(K+NI),X(K),Y(K))
     .         .OR.  LEFT(X(K),Y(K),X(KP1+NI),Y(KP1+NI),
     .                    X(K+NI),Y(K+NI))
     .         .OR.  LEFT(X(K+NI),Y(K+NI),X(KP1),Y(KP1),
     .                    X(KP1+NI),Y(KP1+NI))
     .         .OR.  LEFT(X(KP1+NI),Y(KP1+NI),X(K),Y(K),
     .                    X(KP1),Y(KP1)) )          GO TO 12
          IF ( SWPTST(KP1,K+NI,K,KP1+NI,X,Y) ) GO TO 2
          M4 = -1
          LP = LP + 1
          LIST(LP) = KP1 + NI
          LPTR(LP) = LP + 1
C
C   The next (or first) neighbor is to the right of K.
C
    2     LP = LP + 1
          LIST(LP) = KP1
          LPTR(LP) = LP + 1
C
C   Test for a positive diagonal in quadrant 1 (the neighbor
C     of K-NI which follows K is not K+1) unless K is in the
C     top row.
C
          IF (J .EQ. 1) GO TO 3
          IF (TST) THEN
            M1 = -1
            LPK = LSTPTR(LEND(K-NI),K,LIST,LPTR)
            LPK = LPTR(LPK)
            IF (LIST(LPK) .NE. KP1) THEN
              M1 = 1
              LP = LP + 1
              LIST(LP) = KP1 - NI
              LPTR(LP) = LP + 1
            ENDIF
          ENDIF
C
C   If K is in the leftmost column (and not the top row) or
C     in the bottom row (and not the rightmost column), then
C     the next neighbor is the node above K.
C
          IF (I .NE. 1  .AND.  J .NE. NJ) GO TO 4
          LP = LP + 1
          LIST(LP) = K - NI
          LPTR(LP) = LP + 1
          IF (I .EQ. 1) GO TO 3
C
C   K is on the bottom row (and not the leftmost or right-
C     most column).
C
          IF (M2 .LE. 0) THEN
            LP = LP + 1
            LIST(LP) = K - 1 - NI
            LPTR(LP) = LP + 1
          ENDIF
          LP = LP + 1
          LIST(LP) = K - 1
          LPTR(LP) = LP + 1
C
C   K is a boundary node.
C
    3     LIST(LP) = -LIST(LP)
C
C   Bottom of loop.  Store LEND and correct LPTR(LP).
C     LPF and LP point to the first and last neighbors
C     of K.
C
    4     LEND(K) = LP
          LPTR(LP) = LPF
    5     CONTINUE
    6   CONTINUE
C
C Store LNEW, and terminate the algorithm if NIT = 0 on
C   input.
C
      LNEW = LP + 1
      IF (MAXIT .EQ. 0) RETURN
C
C Add boundary arcs where necessary in order to cover the
C   convex hull of the nodes.  N1, N2, and N3 are consecu-
C   tive boundary nodes in counterclockwise order, and N0
C   is the starting point for each loop around the boundary.
C
      N0 = 1
      N1 = N0
      N2 = NI + 1
C
C   TST is set to TRUE if an arc is added.  The boundary
C     loop is repeated until a traversal results in no
C     added arcs.
C
    7 TST = .FALSE.
C
C   Top of boundary loop.  Set N3 to the first neighbor of
C     N2, and test for N3 LEFT N1 -> N2.
C
    8   LPL = LEND(N2)
          LP = LPTR(LPL)
          N3 = LIST(LP)
          IF ( LEFT(X(N1),Y(N1),X(N2),Y(N2),X(N3),Y(N3)) )
     .       N1 = N2
          IF (N1 .NE. N2) THEN
C
C   Add the boundary arc N1-N3.  If N0 = N2, the starting
C     point is changed to N3, since N2 will be removed from
C     the boundary.  N3 is inserted as the first neighbor of
C     N1, N2 is changed to an interior node, and N1 is
C     inserted as the last neighbor of N3.
C
            TST = .TRUE.
            IF (N2 .EQ. N0) N0 = N3
            LP = LEND(N1)
            CALL INSERT (N3,LP, LIST,LPTR,LNEW )
            LIST(LPL) = -LIST(LPL)
            LP = LEND(N3)
            LIST(LP) = N2
            CALL INSERT (-N1,LP, LIST,LPTR,LNEW )
            LEND(N3) = LNEW - 1
          ENDIF
C
C   Bottom of loops.  Test for termination.
C
          N2 = N3
          IF (N1 .NE. N0) GO TO 8
        IF (TST) GO TO 7
C
C Terminate the algorithm if NIT = 1 on input.
C
      NIT = 1
      IF (MAXIT .EQ. 1) RETURN
C
C Optimize the triangulation by applying the swap test and
C   appropriate swaps to the interior arcs.  The loop is
C   repeated until no swaps are performed or MAXIT itera-
C   tions have been applied.  ITER is the current iteration,
C   and TST is set to TRUE if a swap occurs.
C
      ITER = 1
      NM1 = NN - 1
    9 ITER = ITER + 1
        TST = .FALSE.
C
C   Loop on interior arcs N1-N2, where N2 > N1 and
C     (N1,N2,N3) and (N2,N1,N4) are adjacent triangles.
C
C   Top of loop on nodes N1.
C
        DO 11 N1 = 1,NM1
          LPL = LEND(N1)
          N4 = LIST(LPL)
          LPF = LPTR(LPL)
          N2 = LIST(LPF)
          LP = LPTR(LPF)
          N3 = LIST(LP)
          NNB = NBCNT(LPL,LPTR)
C
C   Top of loop on neighbors N2 of N1.  NNB is the number of
C                                       neighbors of N1.
C
          DO 10 I = 1,NNB
C
C   Bypass the swap test if N1 is a boundary node and N2 is
C     the first neighbor (N4 < 0), N2 < N1, or N1-N2 is a
C     diagonal arc (already locally optimal) when ITER = 2.
C
            IF ( N4 .GT. 0  .AND.  N2 .GT. N1  .AND.
     .          (ITER .NE. 2  .OR.  ABS(N1+NI-N2) .NE. 1) )
     .          THEN
              IF (SWPTST(N3,N4,N1,N2,X,Y) ) THEN
C
C   Swap diagonal N1-N2 for N3-N4, set TST to TRUE, and set
C     N2 to N4 (the neighbor preceding N3).
C
                CALL SWAP (N3,N4,N1,N2, LIST,LPTR,LEND, LPP)
                IF (LPP .NE. 0) THEN
                  TST = .TRUE.
                  N2 = N4
                ENDIF
              ENDIF
            ENDIF
C
C   Bottom of neighbor loop.
C
            IF (LIST(LPL) .EQ. -N3) GO TO 11
            N4 = N2
            N2 = N3
            LP = LSTPTR(LPL,N2,LIST,LPTR)
            LP = LPTR(LP)
            N3 = ABS(LIST(LP))
   10       CONTINUE
   11     CONTINUE
C
C   Test for termination.
C
        IF (TST  .AND.  ITER .LT. MAXIT) GO TO 9
      NIT = ITER
      IF (TST) IER = -2
      RETURN
C
C Invalid grid cell encountered.
C
   12 IER = K
      RETURN
      END
      SUBROUTINE TRPLOT (LUN,PLTSIZ,WX1,WX2,WY1,WY2,NCC,LCC,
     .                   N,X,Y,LIST,LPTR,LEND,TITLE,
     .                   NUMBR, IER)
      CHARACTER*(*) TITLE
      INTEGER LUN, NCC, LCC(*), N, LIST(*), LPTR(*),
     .        LEND(N), IER
      LOGICAL NUMBR
      DOUBLE PRECISION PLTSIZ, WX1, WX2, WY1, WY2, X(N),
     .        Y(N)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/15/98
C
C   This subroutine creates a level-2 Encapsulated Post-
C script (EPS) file containing a triangulation plot.
C
C
C On input:
C
C       LUN = Logical unit number in the range 0 to 99.
C             The unit should be opened with an appropriate
C             file name before the call to this routine.
C
C       PLTSIZ = Plot size in inches.  The window is mapped,
C                with aspect ratio preserved, to a rectangu-
C                lar viewport with maximum side-length equal
C                to .88*PLTSIZ (leaving room for labels out-
C                side the viewport).  The viewport is
C                centered on the 8.5 by 11 inch page, and
C                its boundary is drawn.  1.0 .LE. PLTSIZ
C                .LE. 8.5.
C
C       WX1,WX2,WY1,WY2 = Parameters defining a rectangular
C                         window against which the triangu-
C                         lation is clipped.  (Only the
C                         portion of the triangulation that
C                         lies in the window is drawn.)
C                         (WX1,WY1) and (WX2,WY2) are the
C                         lower left and upper right cor-
C                         ners, respectively.  WX1 < WX2 and
C                         WY1 < WY2.
C
C       NCC = Number of constraint curves.  Refer to Subrou-
C             tine ADDCST.  NCC .GE. 0.
C
C       LCC = Array of length NCC (or dummy parameter if
C             NCC = 0) containing the index of the first
C             node of constraint I in LCC(I).  For I = 1 to
C             NCC, LCC(I+1)-LCC(I) .GE. 3, where LCC(NCC+1)
C             = N+1.
C
C       N = Number of nodes in the triangulation.  N .GE. 3.
C
C       X,Y = Arrays of length N containing the coordinates
C             of the nodes with non-constraint nodes in the
C             first LCC(1)-1 locations.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C       TITLE = Type CHARACTER variable or constant contain-
C               ing a string to be centered above the plot.
C               The string must be enclosed in parentheses;
C               i.e., the first and last characters must be
C               '(' and ')', respectively, but these are not
C               displayed.  TITLE may have at most 80 char-
C               acters including the parentheses.
C
C       NUMBR = Option indicator:  If NUMBR = TRUE, the
C               nodal indexes are plotted next to the nodes.
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if LUN, PLTSIZ, NCC, or N is outside
C                     its valid range.  LCC is not tested
C                     for validity.
C             IER = 2 if WX1 >= WX2 or WY1 >= WY2.
C             IER = 3 if an error was encountered in writing
C                     to unit LUN.
C
C   Various plotting options can be controlled by altering
C the data statement below.
C
C Modules required by TRPLOT:  None
C
C Intrinsic functions called by TRPLOT:  ABS, CHAR, NINT,
C                                          DBLE
C
C***********************************************************
C
      INTEGER I, IFRST, IH, ILAST, IPX1, IPX2, IPY1, IPY2,
     .        IW, LP, LPL, N0, N0BAK, N0FOR, N1, NLS
      LOGICAL ANNOT, CNSTR, PASS1
      DOUBLE PRECISION DASHL, DX, DY, FSIZN, FSIZT, R, SFX,
     .        SFY, T, TX, TY, X0, Y0
C
      DATA    ANNOT/.TRUE./,  DASHL/4.0/,  FSIZN/10.0/,
     .        FSIZT/16.0/
C
C Local parameters:
C
C ANNOT =     Logical variable with value TRUE iff the plot
C               is to be annotated with the values of WX1,
C               WX2, WY1, and WY2
C CNSTR       Logical variable used to flag constraint arcs:
C               TRUE iff N0-N1 lies in a constraint region
C DASHL =     Length (in points, at 72 points per inch) of
C               dashes and spaces in a dashed line pattern
C               used for drawing constraint arcs
C DX =        Window width WX2-WX1
C DY =        Window height WY2-WY1
C FSIZN =     Font size in points for labeling nodes with
C               their indexes if NUMBR = TRUE
C FSIZT =     Font size in points for the title (and
C               annotation if ANNOT = TRUE)
C I =         Constraint index (1 to NCC)
C IFRST =     Index of the first node in constraint I
C IH =        Height of the viewport in points
C ILAST =     Index of the last node in constraint I
C IPX1,IPY1 = X and y coordinates (in points) of the lower
C               left corner of the bounding box or viewport
C IPX2,IPY2 = X and y coordinates (in points) of the upper
C               right corner of the bounding box or viewport
C IW =        Width of the viewport in points
C LP =        LIST index (pointer)
C LPL =       Pointer to the last neighbor of N0
C N0 =        Nodal index and DO-loop index
C N0BAK =     Predecessor of N0 in a constraint curve
C               (sequence of adjacent constraint nodes)
C N0FOR =     Successor to N0 in a constraint curve
C N1 =        Index of a neighbor of N0
C NLS =       Index of the last non-constraint node
C PASS1 =     Logical variable used to flag the first pass
C               through the constraint nodes
C R =         Aspect ratio DX/DY
C SFX,SFY =   Scale factors for mapping world coordinates
C               (window coordinates in [WX1,WX2] X [WY1,WY2])
C               to viewport coordinates in [IPX1,IPX2] X
C               [IPY1,IPY2]
C T =         Temporary variable
C TX,TY =     Translation vector for mapping world coordi-
C               nates to viewport coordinates
C X0,Y0 =     X(N0),Y(N0) or label location
C
C
C Test for error 1, and set NLS to the last non-constraint
C   node.
C
      IF (LUN .LT. 0  .OR.  LUN .GT. 99  .OR.
     .    PLTSIZ .LT. 1.0  .OR.  PLTSIZ .GT. 8.5  .OR.
     .    NCC .LT. 0  .OR.  N .LT. 3) GO TO 11
      NLS = N
      IF (NCC .GT. 0) NLS = LCC(1)-1
C
C Compute the aspect ratio of the window.
C
      DX = WX2 - WX1
      DY = WY2 - WY1
      IF (DX .LE. 0.0  .OR.  DY .LE. 0.0) GO TO 12
      R = DX/DY
C
C Compute the lower left (IPX1,IPY1) and upper right
C   (IPX2,IPY2) corner coordinates of the bounding box.
C   The coordinates, specified in default user space units
C   (points, at 72 points/inch with origin at the lower
C   left corner of the page), are chosen to preserve the
C   aspect ratio R, and to center the plot on the 8.5 by 11
C   inch page.  The center of the page is (306,396), and
C   T = PLTSIZ/2 in points.
C
      T = 36.0*PLTSIZ
      IF (R .GE. 1.0) THEN
        IPX1 = 306 - NINT(T)
        IPX2 = 306 + NINT(T)
        IPY1 = 396 - NINT(T/R)
        IPY2 = 396 + NINT(T/R)
      ELSE
        IPX1 = 306 - NINT(T*R)
        IPX2 = 306 + NINT(T*R)
        IPY1 = 396 - NINT(T)
        IPY2 = 396 + NINT(T)
      ENDIF
C
C Output header comments.
C
      WRITE (LUN,100,ERR=13) IPX1, IPY1, IPX2, IPY2
  100 FORMAT ('%!PS-Adobe-3.0 EPSF-3.0'/
     .        '%%BoundingBox:',4I4/
     .        '%%Title:  Triangulation'/
     .        '%%Creator:  TRIPACK'/
     .        '%%EndComments')
C
C Set (IPX1,IPY1) and (IPX2,IPY2) to the corner coordinates
C   of a viewport obtained by shrinking the bounding box by
C   12% in each dimension.
C
      IW = NINT(0.88*DBLE(IPX2-IPX1))
      IH = NINT(0.88*DBLE(IPY2-IPY1))
      IPX1 = 306 - IW/2
      IPX2 = 306 + IW/2
      IPY1 = 396 - IH/2
      IPY2 = 396 + IH/2
C
C Set the line thickness to 2 points, and draw the
C   viewport boundary.
C
      T = 2.0
      WRITE (LUN,110,ERR=13) T
      WRITE (LUN,120,ERR=13) IPX1, IPY1
      WRITE (LUN,130,ERR=13) IPX1, IPY2
      WRITE (LUN,130,ERR=13) IPX2, IPY2
      WRITE (LUN,130,ERR=13) IPX2, IPY1
      WRITE (LUN,140,ERR=13)
      WRITE (LUN,150,ERR=13)
  110 FORMAT (F12.6,' setlinewidth')
  120 FORMAT (2I4,' moveto')
  130 FORMAT (2I4,' lineto')
  140 FORMAT ('closepath')
  150 FORMAT ('stroke')
C
C Set up a mapping from the window to the viewport.
C
      SFX = DBLE(IW)/DX
      SFY = DBLE(IH)/DY
      TX = IPX1 - SFX*WX1
      TY = IPY1 - SFY*WY1
      WRITE (LUN,160,ERR=13) TX, TY, SFX, SFY
  160 FORMAT (2F12.6,' translate'/
     .        2F12.6,' scale')
C
C The line thickness (believe it or fucking not) must be
C   changed to reflect the new scaling which is applied to
C   all subsequent output.  Set it to 1.0 point.
C
      T = 2.0/(SFX+SFY)
      WRITE (LUN,110,ERR=13) T
C
C Save the current graphics state, and set the clip path to
C   the boundary of the window.
C
      WRITE (LUN,170,ERR=13)
      WRITE (LUN,180,ERR=13) WX1, WY1
      WRITE (LUN,190,ERR=13) WX2, WY1
      WRITE (LUN,190,ERR=13) WX2, WY2
      WRITE (LUN,190,ERR=13) WX1, WY2
      WRITE (LUN,200,ERR=13)
  170 FORMAT ('gsave')
  180 FORMAT (2F12.6,' moveto')
  190 FORMAT (2F12.6,' lineto')
  200 FORMAT ('closepath clip newpath')
C
C Draw the edges N0->N1, where N1 > N0, beginning with a
C   loop on non-constraint nodes N0.  LPL points to the
C   last neighbor of N0.
C
      DO 3 N0 = 1,NLS
        X0 = X(N0)
        Y0 = Y(N0)
        LPL = LEND(N0)
        LP = LPL
C
C   Loop on neighbors N1 of N0.
C
    2   LP = LPTR(LP)
          N1 = ABS(LIST(LP))
          IF (N1 .GT. N0) THEN
C
C   Add the edge to the path.
C
            WRITE (LUN,210,ERR=13) X0, Y0, X(N1), Y(N1)
  210       FORMAT (2F12.6,' moveto',2F12.6,' lineto')
          ENDIF
          IF (LP .NE. LPL) GO TO 2
    3   CONTINUE
C
C Loop through the constraint nodes twice.  The non-
C   constraint arcs incident on constraint nodes are
C   drawn (with solid lines) on the first pass, and the
C   constraint arcs (both boundary and interior, if any)
C   are drawn (with dashed lines) on the second pass.
C
      PASS1 = .TRUE.
C
C Loop on constraint nodes N0 with (N0BAK,N0,N0FOR) a sub-
C   sequence of constraint I.  The outer loop is on
C   constraints I with first and last nodes IFRST and ILAST.
C
    4 IFRST = N+1
      DO 8 I = NCC,1,-1
        ILAST = IFRST - 1
        IFRST = LCC(I)
        N0BAK = ILAST
        DO 7 N0 = IFRST,ILAST
          N0FOR = N0 + 1
          IF (N0 .EQ. ILAST) N0FOR = IFRST
          LPL = LEND(N0)
          X0 = X(N0)
          Y0 = Y(N0)
          LP = LPL
C
C   Loop on neighbors N1 of N0.  CNSTR = TRUE iff N0-N1 is a
C     constraint arc.
C
C   Initialize CNSTR to TRUE iff the first neighbor of N0
C     strictly follows N0FOR and precedes or coincides with
C     N0BAK (in counterclockwise order).
C
    5     LP = LPTR(LP)
            N1 = ABS(LIST(LP))
            IF (N1 .NE. N0FOR  .AND.  N1 .NE. N0BAK) GO TO 5
          CNSTR = N1 .EQ. N0BAK
          LP = LPL
C
C   Loop on neighbors N1 of N0.  Update CNSTR and test for
C     N1 > N0.
C
    6     LP = LPTR(LP)
            N1 = ABS(LIST(LP))
            IF (N1 .EQ. N0FOR) CNSTR = .TRUE.
            IF (N1 .GT. N0) THEN
C
C   Draw the edge iff (PASS1=TRUE and CNSTR=FALSE) or
C     (PASS1=FALSE and CNSTR=TRUE); i.e., CNSTR and PASS1
C     have opposite values.
C
              IF (CNSTR .NEQV. PASS1)
     .          WRITE (LUN,210,ERR=13) X0, Y0, X(N1), Y(N1)
            ENDIF
            IF (N1 .EQ. N0BAK) CNSTR = .FALSE.
C
C   Bottom of loops.
C
            IF (LP .NE. LPL) GO TO 6
          N0BAK = N0
    7     CONTINUE
    8   CONTINUE
      IF (PASS1) THEN
C
C End of first pass:  paint the path and change to dashed
C   lines for subsequent drawing.  Since the scale factors
C   are applied to everything, the dash length must be
C   specified in world coordinates.
C
        PASS1 = .FALSE.
        WRITE (LUN,150,ERR=13)
        T = DASHL*2.0/(SFX+SFY)
        WRITE (LUN,220,ERR=13) T
  220   FORMAT ('[',F12.6,'] 0 setdash')
        GO TO 4
      ENDIF
C
C Paint the path and restore the saved graphics state (with
C   no clip path).
C
      WRITE (LUN,150,ERR=13)
      WRITE (LUN,230,ERR=13)
  230 FORMAT ('grestore')
      IF (NUMBR) THEN
C
C Nodes in the window are to be labeled with their indexes.
C   Convert FSIZN from points to world coordinates, and
C   output the commands to select a font and scale it.
C
        T = FSIZN*2.0/(SFX+SFY)
        WRITE (LUN,240,ERR=13) T
  240   FORMAT ('/Helvetica findfont'/
     .          F12.6,' scalefont setfont')
C
C   Loop on nodes N0 with coordinates (X0,Y0).
C
        DO 9 N0 = 1,N
          X0 = X(N0)
          Y0 = Y(N0)
          IF (X0 .LT. WX1  .OR.  X0 .GT. WX2  .OR.
     .        Y0 .LT. WY1  .OR.  Y0 .GT. WY2) GO TO 9
C
C   Move to (X0,Y0), and draw the label N0.  The first char-
C     acter will have its lower left corner about one
C     character width to the right of the nodal position.
C
          WRITE (LUN,180,ERR=13) X0, Y0
          WRITE (LUN,250,ERR=13) N0
  250     FORMAT ('(',I3,') show')
    9     CONTINUE
      ENDIF
C
C Convert FSIZT from points to world coordinates, and output
C   the commands to select a font and scale it.
C
      T = FSIZT*2.0/(SFX+SFY)
      WRITE (LUN,240,ERR=13) T
C
C Display TITLE centered above the plot:
C
      Y0 = WY2 + 3.0*T
      WRITE (LUN,260,ERR=13) TITLE, (WX1+WX2)/2.0, Y0
  260 FORMAT (A80/'  stringwidth pop 2 div neg ',F12.6,
     .        ' add ',F12.6,' moveto')
      WRITE (LUN,270,ERR=13) TITLE
  270 FORMAT (A80/'  show')
      IF (ANNOT) THEN
C
C Display the window extrema below the plot.
C
        X0 = WX1
        Y0 = WY1 - 100.0/(SFX+SFY)
        WRITE (LUN,180,ERR=13) X0, Y0
        WRITE (LUN,280,ERR=13) WX1, WX2
        Y0 = Y0 - 2.0*T
        WRITE (LUN,290,ERR=13) X0, Y0, WY1, WY2
  280   FORMAT ('(Window:   WX1 = ',E10.3,',   WX2 = ',E10.3,
     .          ') show')
  290   FORMAT ('(Window:  ) stringwidth pop ',F12.6,' add',
     .          F12.6,' moveto'/
     .          '( WY1 = ',E10.3,',   WY2 = ',E10.3,') show')
      ENDIF
C
C Paint the path and output the showpage command and
C   end-of-file indicator.
C
      WRITE (LUN,300,ERR=13)
  300 FORMAT ('stroke'/
     .        'showpage'/
     .        '%%EOF')
C
C HP's interpreters require a one-byte End-of-PostScript-Job
C   indicator (to eliminate a timeout error message):
C   ASCII 4.
C
      WRITE (LUN,310,ERR=13) CHAR(4)
  310 FORMAT (A1)
C
C No error encountered.
C
      IER = 0
      RETURN
C
C Invalid input parameter.
C
   11 IER = 1
      RETURN
C
C DX or DY is not positive.
C
   12 IER = 2
      RETURN
C
C Error writing to unit LUN.
C
   13 IER = 3
      RETURN
      END

      SUBROUTINE TRPRNT (NCC,LCC,N,X,Y,LIST,LPTR,LEND,LOUT,
     .                   PRNTX)
      INTEGER NCC, LCC(*), N, LIST(*), LPTR(*), LEND(N),
     .        LOUT
      LOGICAL PRNTX
      DOUBLE PRECISION X(N), Y(N)
C
C***********************************************************
C
C                                               From TRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/30/98
C
C   Given a triangulation of a set of points in the plane,
C this subroutine prints the adjacency lists and, option-
C ally, the nodal coordinates on logical unit LOUT.  The
C list of neighbors of a boundary node is followed by index
C 0.  The numbers of boundary nodes, triangles, and arcs,
C and the constraint curve starting indexes, if any, are
C also printed.
C
C
C On input:
C
C       NCC = Number of constraints.
C
C       LCC = List of constraint curve starting indexes (or
C             dummy array of length 1 if NCC = 0).
C
C       N = Number of nodes in the triangulation.
C           3 .LE. N .LE. 9999.
C
C       X,Y = Arrays of length N containing the coordinates
C             of the nodes in the triangulation -- not used
C             unless PRNTX = TRUE.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to Subroutine
C                        TRMESH.
C
C       LOUT = Logical unit number for output.  0 .LE. LOUT
C              .LE. 99.  Output is printed on unit 6 if LOUT
C              is outside its valid range on input.
C
C       PRNTX = Logical variable with value TRUE if and only
C               if X and Y are to be printed (to 6 decimal
C               places).
C
C None of the parameters are altered by this routine.
C
C Modules required by TRPRNT:  None
C
C***********************************************************
C
      INTEGER I, INC, K, LP, LPL, LUN, NA, NABOR(100), NB,
     .        ND, NL, NLMAX, NMAX, NODE, NN, NT
      DATA  NMAX/9999/,  NLMAX/60/
C
      NN = N
      LUN = LOUT
      IF (LUN .LT. 0  .OR.  LUN .GT. 99) LUN = 6
C
C Print a heading and test the range of N.
C
      WRITE (LUN,100) NN
      IF (NN .LT. 3  .OR.  NN .GT. NMAX) THEN
C
C N is outside its valid range.
C
        WRITE (LUN,110)
        GO TO 5
      ENDIF
C
C Initialize NL (the number of lines printed on the current
C   page) and NB (the number of boundary nodes encountered).
C
      NL = 6
      NB = 0
      IF (.NOT. PRNTX) THEN
C
C Print LIST only.  K is the number of neighbors of NODE
C   which are stored in NABOR.
C
        WRITE (LUN,101)
        DO 2 NODE = 1,NN
          LPL = LEND(NODE)
          LP = LPL
          K = 0
C
    1     K = K + 1
            LP = LPTR(LP)
            ND = LIST(LP)
            NABOR(K) = ND
            IF (LP .NE. LPL) GO TO 1
          IF (ND .LE. 0) THEN
C
C   NODE is a boundary node.  Correct the sign of the last
C     neighbor, add 0 to the end of the list, and increment
C     NB.
C
            NABOR(K) = -ND
            K = K + 1
            NABOR(K) = 0
            NB = NB + 1
          ENDIF
C
C   Increment NL and print the list of neighbors.
C
          INC = (K-1)/14 + 2
          NL = NL + INC
          IF (NL .GT. NLMAX) THEN
            WRITE (LUN,106)
            NL = INC
          ENDIF
          WRITE (LUN,103) NODE, (NABOR(I), I = 1,K)
          IF (K .NE. 14) WRITE (LUN,105)
    2     CONTINUE
      ELSE
C
C Print X, Y, and LIST.
C
        WRITE (LUN,102)
        DO 4 NODE = 1,NN
          LPL = LEND(NODE)
          LP = LPL
          K = 0
    3     K = K + 1
            LP = LPTR(LP)
            ND = LIST(LP)
            NABOR(K) = ND
            IF (LP .NE. LPL) GO TO 3
          IF (ND .LE. 0) THEN
C
C   NODE is a boundary node.
C
            NABOR(K) = -ND
            K = K + 1
            NABOR(K) = 0
            NB = NB + 1
          ENDIF
C
C   Increment NL and print X, Y, and NABOR.
C
          INC = (K-1)/8 + 2
          NL = NL + INC
          IF (NL .GT. NLMAX) THEN
            WRITE (LUN,106)
            NL = INC
          ENDIF
          WRITE (LUN,104) NODE, X(NODE), Y(NODE),
     .                    (NABOR(I), I = 1,K)
          IF (K .NE. 8) WRITE (LUN,105)
    4     CONTINUE
      ENDIF
C
C Print NB, NA, and NT (boundary nodes, arcs, and
C   triangles).
C
      NT = 2*NN - NB - 2
      NA = NT + NN - 1
      IF (NL .GT. NLMAX-6) WRITE (LUN,106)
      WRITE (LUN,107) NB, NA, NT
C
C Print NCC and LCC.
C
    5 WRITE (LUN,108) NCC
      IF (NCC .GT. 0) WRITE (LUN,109) (LCC(I), I = 1,NCC)
      RETURN
C
C Print formats:
C
  100 FORMAT (///,26X,'Adjacency Sets,    N = ',I5//)
  101 FORMAT (1X,'Node',32X,'Neighbors of Node'//)
  102 FORMAT (1X,'Node',5X,'X(Node)',8X,'Y(Node)',
     .        20X,'Neighbors of Node'//)
  103 FORMAT (1X,I4,5X,14I5/(1X,9X,14I5))
  104 FORMAT (1X,I4,2E15.6,5X,8I5/(1X,39X,8I5))
  105 FORMAT (1X)
  106 FORMAT (///)
  107 FORMAT (/1X,'NB = ',I4,' Boundary Nodes',5X,
     .        'NA = ',I5,' Arcs',5X,'NT = ',I5,
     .        ' Triangles')
  108 FORMAT (/1X,'NCC =',I3,' Constraint Curves')
  109 FORMAT (1X,9X,14I5)
  110 FORMAT (1X,10X,'*** N is outside its valid',
     .        ' range ***')
      END
      SubroutineWHENIGT(n,x,incx,itarget,index,nn)
      integern,x(n),incx,itarget,index(n),nn
      nn=0
      DO09999i=1,n,incx
      if(x(i).GT.itarget)then
      nn=nn+1
      index(nn)=i
      endif
09999 CONTINUE
      return
      end
      SubroutineWHENEQ(n,x,incx,itarget,index,nn)
      integern,x(n),incx,itarget,index(n),nn
      nn=0
      DO09996i=1,n,incx
      if(x(i).EQ.itarget)then
      nn=nn+1
      index(nn)=i
      endif
09996 CONTINUE
      return
      end
      SubroutineWHENNE(n,x,incx,itarget,index,nn)
      integern,x(n),incx,itarget,index(n),nn
      nn=0
      DO09993i=1,n,incx
      if(x(i).NE.itarget)then
      nn=nn+1
      index(nn)=i
      endif
09993 CONTINUE
      return
      end
      Integerfunctioncvmgt(i,j,lx)
      integeri,j
      logicallx
      if(lx)then
      cvmgt=i
      else
      cvmgt=j
      endif
      write(*,*)' cvmgt i,j,lx',i,j,lx
      return
      end
      IntegerfunctionIsmin(n,x,incx)
      integern,incx
      doubleprecisionx(n)
      nn=1
      DO09990i=incx+1,n,incx
      if(x(i).LT.x(nn))nn=i
09990 CONTINUE
      Ismin=nn
      return
      end
      IntegerfunctionIrmin(n,x,incx)
      integern,incx
      realx(n)
      nn=1
      DO09987i=incx+1,n,incx
      if(x(i).LT.x(nn))nn=i
09987 CONTINUE
      Irmin=nn
      return
      end
      IntegerfunctionIsmax(n,x,incx)
      integern,incx
      doubleprecisionx(n)
      nn=1
      DO09984i=incx+1,n,incx
      if(x(i).GT.x(nn))nn=i
09984 CONTINUE
      Ismax=nn
      return
      end
      IntegerfunctionIrmax(n,x,incx)
      integern,incx
      realx(n)
      nn=1
      DO09981i=incx+1,n,incx
      if(x(i).GT.x(nn))nn=i
09981 CONTINUE
      Irmax=nn
      return
      end

      DOUBLE PRECISION FUNCTION S15ADF(X,IFAIL)
C     MARK 5A REVISED - NAG COPYRIGHT 1976
C     MARK 5C REVISED
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     COMPLEMENT OF ERROR FUNCTION ERFC(X)
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION                 X
      INTEGER                          IFAIL
C     .. Local Scalars ..
      DOUBLE PRECISION                 T, XHI, XLO, Y
C     .. Intrinsic Functions ..
      INTRINSIC                        ABS, EXP
C     .. Data statements ..
C     PRECISION DEPENDENT CONSTANTS
C08   DATA XLO/-4.5D0/
C12   DATA XLO/-5.25D0/
C14   DATA XLO/-5.75D0/
      DATA XLO/-6.25D0/
C18   DATA XLO/-6.5D0/
C
C     RANGE DEPENDENT CONSTANTS
      DATA XHI/ 2.66D+1 /
C     XHI = LARGEST X SUCH THAT EXP(-X*X) .GT. MINREAL (ROUNDED DOWN)
CR1   DATA XHI/13.0D0/
CR2   DATA XHI/9.5D0/
CR3   DATA XHI/13.0D0/
CR4   DATA XHI/25.0D0/
CR5   DATA XHI/26.0D0/
C     .. Executable Statements ..
C
C     NO FAILURE EXITS
      IFAIL = 0
C     TEST EXTREME EXITS
      IF (X.GE.XHI) GO TO 20
      IF (X.LE.XLO) GO TO 40
C
C     EXPANSION ARGUMENT
      T = 1.0D0 - 7.5D0/(ABS(X)+3.75D0)
C
C      * EXPANSION (0021) *
C
C     EXPANSION (0021) EVALUATED AS Y(T)  --PRECISION 08E
C08   Y = (((((((((((+3.1475326D-5)*T-1.3874589D-4)*T-6.4127909D-6)
C08  *    *T+1.7866301D-3)*T-8.2316935D-3)*T+2.4151896D-2)
C08  *    *T-5.4799165D-2)*T+1.0260225D-1)*T-1.6357229D-1)
C08  *    *T+2.2600824D-1)*T-2.7342192D-1)*T + 1.4558972D-1
C
C     EXPANSION (0021) EVALUATED AS Y(T)  --PRECISION 12E
C12   Y = ((((((((((((((((-4.21661579602D-8*T-8.63384346353D-8)
C12  *    *T+6.06038693567D-7)*T+5.90655413508D-7)
C12  *    *T-6.12872971594D-6)*T+3.73223486059D-6)
C12  *    *T+4.78645837248D-5)*T-1.52546487034D-4)
C12  *    *T-2.55222360474D-5)*T+1.80299061562D-3)
C12  *    *T-8.22062412199D-3)*T+2.41432185990D-2)
C12  *    *T-5.48023263289D-2)*T+1.02604312548D-1)
C12  *    *T-1.63571895545D-1)*T+2.26008066898D-1)
C12  *    *T-2.73421931495D-1)*T + 1.45589721275D-1
C
C     EXPANSION (0021) EVALUATED AS Y(T)  --PRECISION 14E
C14   Y = (((((((((((((((-2.2356173494379D-9
C14  *    *T+4.5302502889845D-9)*T+2.5918103316137D-8)
C14  *    *T-6.3684846832869D-8)*T-1.7642194353331D-7)
C14  *    *T+6.4907607131235D-7)*T+7.4296952017617D-7)
C14  *    *T-6.1758018478516D-6)*T+3.5866167916231D-6)
C14  *    *T+4.7895180610590D-5)*T-1.5246364229106D-4)
C14  *    *T-2.5534256252531D-5)*T+1.8029626230333D-3)
C14  *    *T-8.2206213481002D-3)*T+2.4143223946968D-2)
C14  *    *T-5.4802326675661D-2)*T+1.0260431203382D-1
C14   Y = (((Y*T-1.6357189552481D-1)*T+2.2600806691658D-1)
C14  *    *T-2.7342193149541D-1)*T + 1.4558972127504D-1
C
C     EXPANSION (0021) EVALUATED AS Y(T)  --PRECISION 16E
      Y = (((((((((((((((+3.328130055126039D-10
     *    *T-5.718639670776992D-10)*T-4.066088879757269D-9)
     *    *T+7.532536116142436D-9)*T+3.026547320064576D-8)
     *    *T-7.043998994397452D-8)*T-1.822565715362025D-7)
     *    *T+6.575825478226343D-7)*T+7.478317101785790D-7)
     *    *T-6.182369348098529D-6)*T+3.584014089915968D-6)
     *    *T+4.789838226695987D-5)*T-1.524627476123466D-4)
     *    *T-2.553523453642242D-5)*T+1.802962431316418D-3)
     *    *T-8.220621168415435D-3)*T+2.414322397093253D-2
      Y = (((((Y*T-5.480232669380236D-2)*T+1.026043120322792D-1)
     *    *T-1.635718955239687D-1)*T+2.260080669166197D-1)
     *    *T-2.734219314954260D-1)*T + 1.455897212750385D-1
C
C     EXPANSION (0021) EVALUATED AS Y(T)  --PRECISION 18E
C18   Y = (((((((((((((((-1.58023488119651697D-11
C18  *    *T-4.94972069009392927D-11)*T+1.86424953544623784D-10)
C18  *    *T+6.29796246918239617D-10)*T-1.34751340973493898D-9)
C18  *    *T-4.84566988844706300D-9)*T+9.22474802259858004D-9)
C18  *    *T+3.14410318645430670D-8)*T-7.26754673242913196D-8)
C18  *    *T-1.83380699508554268D-7)*T+6.59488268069175234D-7)
C18  *    *T+7.48541685740064308D-7)*T-6.18344429012694168D-6)
C18  *    *T+3.58371497984145357D-6)*T+4.78987832434182054D-5)
C18  *    *T-1.52462664665855354D-4)*T-2.55353311432760448D-5
C18   Y = ((((((((Y*T+1.80296241673597993D-3)
C18  *    *T-8.22062115413991215D-3)
C18  *    *T+2.41432239724445769D-2)*T-5.48023266949776152D-2)
C18  *    *T+1.02604312032198239D-1)*T-1.63571895523923969D-1)
C18  *    *T+2.26008066916621431D-1)*T-2.73421931495426482D-1)*T +
C18  *     1.45589721275038539D-1
C
      S15ADF = EXP(-X*X)*Y
      IF (X.LT.0.0D0) S15ADF = 2.0D0 - S15ADF
      RETURN
C
   20 S15ADF = 0.0D0
      RETURN
   40 S15ADF = 2.0D0
      RETURN
C
      END

      DOUBLE PRECISION FUNCTION S15AEF(X,IFAIL)
C     MARK 4 RELEASE NAG COPYRIGHT 1974.
C     MARK 4.5 REVISED
C     MARK 8 REVISED. IER-221 (MAR 1980)
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 14 REVISED. IER-755 (DEC 1989).
C     ERF(X)
C
C     **************************************************************
C
C     TO EXTRACT THE CORRECT CODE FOR A PARTICULAR MACHINE-RANGE,
C     ACTIVATE THE STATEMENTS CONTAINED IN COMMENTS BEGINNING  CDD ,
C     WHERE  DD  IS THE APPROXIMATE NUMBER OF SIGNIFICANT DECIMAL
C     DIGITS REPRESENTED BY THE MACHINE
C     DELETE THE ILLEGAL DUMMY STATEMENT OF THE FORM
C     * EXPANSION (DATA) *
C
C     **************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION                 X
      INTEGER                          IFAIL
C     .. Local Scalars ..
      DOUBLE PRECISION                 BJ, BJP1, BJP2, HALF, ONE,
     *                                 SQRTPI, THREE, TWENTY, TWO,
     *                                 X2, XUP, XV, ZERO
      INTEGER                          J, NCFC, NCFD
C     .. Local Arrays ..
C07   DOUBLE PRECISION                 C(8), D(8)
C12   DOUBLE PRECISION                 C(11), D(12)
C14   DOUBLE PRECISION                 C(15), D(15)
      DOUBLE PRECISION                 C(18), D(17)
C     .. Intrinsic Functions ..
      INTRINSIC                        ABS, EXP, SIGN
C     .. Data statements ..
C      * EXPANSION (DATA) *
C07   DATA NCFC,NCFD/8,8/,XUP/4.0D0/,SQRTPI/1.772454D0/
C07  A,C(1),C(2),C(3),C(4),C(5),C(6),C(7),C(8)
C07  A/1.944907D0,4.2019D-2,-1.8687D-2,5.129D-3,-1.068D-3
C07  A,1.74D-4,-2.1D-5,2.0D-6/
C07  A,D(1),D(2),D(3),D(4),D(5),D(6),D(7),D(8)
C07  A/1.483110D0,-3.01071D-1,6.8995D-2,-1.3916D-2,2.421D-3
C07  A,-3.66D-4,4.9D-5,-6.0D-6/
C
C12   DATA NCFC,NCFD/11,12/,XUP/5.0D0/,SQRTPI/1.7724538509D0/,C(1),
C12  * C(2),C(3),C(4),C(5),C(6),C(7),C(8),C(9),C(10),C(11)
C12  * /1.9449071068D0,4.20186582D-2,-1.86866104D-2,5.1281062D-3,
C12  * -1.0683107D-3,1.744738D-4,-2.15642D-5,1.7283D-6,-2.D-8,-1.65D-8,
C12  * 2.D-9/,D(1),D(2),D(3),D(4),D(5),D(6),D(7),D(8),D(9),
C12  * D(10),D(11),D(12)/1.4831105641D0,-3.010710734D-1,6.89948307D-2,
C12  * -1.39162713D-2,2.4207995D-3,-3.658640D-4,4.86210D-5,-5.7493D-6,
C12  * 6.113D-7,-5.90D-8,5.2D-9,-4.D-10/
C
C14   DATA NCFC,NCFD/15,15/,XUP/5.75D0/,SQRTPI/1.7724538509055D0/
C14  A,C(1),C(2),C(3),C(4),C(5),C(6),C(7),C(8),C(9),C(10)
C14  A,C(11),C(12),C(13),C(14),C(15)
C14  A/1.9449071068179D0,4.20186582324D-2,-1.86866103977D-2
C14  A,5.1281061839D-3,-1.0683107462D-3,1.744737872D-4
C14  A,-2.15642056D-5,1.7282658D-6,-2.00479D-8,-1.64782D-8
C14  A,2.0008D-9,2.58D-11,-3.06D-11,1.9D-12,4.0D-13/
C14  A,D(1),D(2),D(3),D(4),D(5),D(6),D(7),D(8),D(9),D(10)
C14  A,D(11),D(12),D(13),D(14),D(15)
C14  A/1.4831105640848D0,-3.010710733866D-1,6.89948306898D-2
C14  A,-1.39162712647D-2,2.4207995224D-3,-3.658639686D-4
C14  A,4.86209844D-5,-5.7492565D-6,6.113243D-7,-5.89910D-8
C14  A,5.2070D-9,-4.233D-10,3.19D-11,-2.2D-12,1.0D-13/
C
      DATA NCFC,NCFD/18,17/,XUP/6.25D0/,SQRTPI/1.7724538509055160D0/
     A,C(1),C(2),C(3),C(4),C(5),C(6),C(7),C(8),C(9),C(10),C(11)
     A,C(12),C(13),C(14),C(15),C(16),C(17),C(18)
     A/1.9449071068178803D0,4.20186582324414D-2,-1.86866103976769D-2
     A,5.1281061839107D-3,-1.0683107461726D-3,1.744737872522D-4
     A,-2.15642065714D-5,1.7282657974D-6,-2.00479241D-8
     A,-1.64782105D-8,2.0008475D-9,2.57716D-11,-3.06343D-11
     A,1.9158D-12,3.703D-13,-5.43D-14,-4.0D-15,1.2D-15/
     A,D(1),D(2),D(3),D(4),D(5),D(6),D(7),D(8),D(9),D(10),D(11)
     A,D(12),D(13),D(14),D(15),D(16),D(17)
     A/1.4831105640848036D0,-3.010710733865950D-1,6.89948306898316D-2
     A,-1.39162712647222D-2,2.4207995224335D-3,-3.658639685849D-4
     A,4.86209844323D-5,-5.7492565580D-6,6.113243578D-7
     A,-5.89910153D-8,5.2070091D-9,-4.232976D-10,3.18811D-11
     A,-2.2361D-12,1.467D-13,-9.0D-15,5.0D-16/
C
      DATA                             ZERO, ONE, TWO, THREE, TWENTY,
     *                                 HALF/0.0D0, 1.0D0, 2.0D0, 3.0D0,
     *                                 20.0D0, 0.5D0/
C     .. Executable Statements ..
C
C     NO FAILURE EXITS
      IFAIL = 0
      XV = ABS(X)
      IF (XV.GE.XUP) GO TO 120
      IF (XV.LE.TWO) GO TO 60
      X2 = TWO - TWENTY/(XV+THREE)
C
C     SUMMATION
      BJP2 = ZERO
      BJP1 = C(NCFC)
      J = NCFC - 1
   20 BJ = X2*BJP1 - BJP2 + C(J)
      IF (J.EQ.1) GO TO 40
      BJP2 = BJP1
      BJP1 = BJ
      J = J - 1
      GO TO 20
   40 X2 = HALF*(BJ-BJP2)/XV*EXP(-X*X)/SQRTPI
      S15AEF = (ONE-X2)*SIGN(ONE,X)
      GO TO 140
C
   60 X2 = X*X - TWO
C     SUMMATION
      BJP2 = ZERO
      BJP1 = D(NCFD)
      J = NCFD - 1
   80 BJ = X2*BJP1 - BJP2 + D(J)
      IF (J.EQ.1) GO TO 100
      BJP2 = BJP1
      BJP1 = BJ
      J = J - 1
      GO TO 80
  100 S15AEF = HALF*(BJ-BJP2)*X
      GO TO 140
C
  120 S15AEF = SIGN(ONE,X)
  140 RETURN
      END

      SUBROUTINE C05NCF(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG,MODE,
     *                  FACTOR,NPRINT,NFEV,FJAC,LDFJAC,R,LR,QTF,W,IFAIL)
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     **********
C
C     SUBROUTINE C05NCF
C
C     The purpose of C05NCF is to interface to C05NCS.
C     The latter is based on MINPACK routine HYBRD.
C
C     **********
C
C     Revised to output explanatory messages.
C     P.J.D. Mayes, NAG Central Office, December 1987.
C
C     .. Parameters ..
      CHARACTER*6       SRNAME
      PARAMETER         (SRNAME='C05NCF')
      DOUBLE PRECISION  ZERO
      PARAMETER         (ZERO=0.0D0)
C     .. Scalar Arguments ..
      DOUBLE PRECISION  EPSFCN, FACTOR, XTOL
      INTEGER           IFAIL, LDFJAC, LR, MAXFEV, ML, MODE, MU, N,
     *                  NFEV, NPRINT
C     .. Array Arguments ..
      DOUBLE PRECISION  DIAG(N), FJAC(LDFJAC,N), FVEC(N), QTF(N), R(LR),
     *                  W(N,4), X(N)
C     .. Subroutine Arguments ..
      EXTERNAL          FCN
C     .. Local Scalars ..
      INTEGER           INFO, LR1, NREC
C     .. Local Arrays ..
      CHARACTER*80      P01REC(2)
C     .. External Functions ..
      INTEGER           P01ABF
      EXTERNAL          P01ABF
C     .. External Subroutines ..
      EXTERNAL          C05NCS
C     .. Executable Statements ..
      INFO = 1
      LR1 = N*(N+1)/2
      NREC = 0
      IF (N.LE.0) THEN
         WRITE (P01REC,FMT=99997) N
         NREC = 1
         GO TO 20
      ELSE IF (LDFJAC.LT.N) THEN
         WRITE (P01REC,FMT=99996) LDFJAC, N
         NREC = 2
         GO TO 20
      ELSE IF (ML.LT.0) THEN
         WRITE (P01REC,FMT=99999) ML
         NREC = 1
         GO TO 20
      ELSE IF (MU.LT.0) THEN
         WRITE (P01REC,FMT=99998) MU
         NREC = 1
         GO TO 20
      ELSE IF (XTOL.LT.ZERO) THEN
         WRITE (P01REC,FMT=99995) XTOL
         NREC = 1
         GO TO 20
      ELSE IF (MAXFEV.LE.0) THEN
         WRITE (P01REC,FMT=99994) MAXFEV
         NREC = 1
         GO TO 20
      ELSE IF (FACTOR.LE.ZERO) THEN
         WRITE (P01REC,FMT=99993) FACTOR
         NREC = 1
         GO TO 20
      ELSE IF (LR.LT.LR1) THEN
         WRITE (P01REC,FMT=99992) LR, LR1
         NREC = 2
         GO TO 20
      END IF
      CALL C05NCS(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG,MODE,
     *            FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR,QTF,W(1,1),
     *            W(1,2),W(1,3),W(1,4))
      IF (INFO.LT.0) THEN
         P01REC(1) = ' ** User set IFLAG negative in FCN'
         NREC = 1
      ELSE IF (INFO.EQ.1) THEN
         P01REC(1) =
     * ' ** On entry, MODE=2 and DIAG contained a non-positive element.'
         NREC = 1
      ELSE IF (INFO.EQ.2) THEN
         WRITE (P01REC,FMT=99991) MAXFEV
         NREC = 1
      ELSE IF (INFO.EQ.3) THEN
         WRITE (P01REC,FMT=99990) XTOL
         NREC = 2
      ELSE IF (INFO.EQ.4) THEN
         P01REC(1) =
     *       ' ** The iteration is not making good progress as measured'
         P01REC(2) =
     *     ' ** by the improvement from the last 5 Jacobian evaluations'
         NREC = 2
      ELSE IF (INFO.EQ.5) THEN
         P01REC(1) =
     *       ' ** The iteration is not making good progress as measured'
         P01REC(2) =
     *              ' ** by the improvement from the last 10 iterations'
         NREC = 2
      END IF
   20 IFAIL = P01ABF(IFAIL,INFO,SRNAME,NREC,P01REC)
      RETURN
C
99999 FORMAT (' ** On entry, ML must be at least 0: ML = ',I16)
99998 FORMAT (' ** On entry, MU must be at least 0: MU = ',I16)
99997 FORMAT (' ** On entry, N must be greater than 0: N = ',I16)
99996 FORMAT (' ** On entry, LDFJAC must be at least N:',/' ** LDFJAC ',
     *       '= ',I16,',    N = ',I16)
99995 FORMAT (' ** On entry, XTOL must be at least 0.0: XTOL = ',1P,
     *       D13.5)
99994 FORMAT (' ** On entry, MAXFEV must be greater than 0: MAXFEV = ',
     *       I16)
99993 FORMAT (' ** On entry, FACTOR must be greater than 0.0: FACTOR = '
     *       ,1P,D13.5)
99992 FORMAT (' ** On entry, LR must be at least N*(N+1)/2:',/' ** LR ',
     *       '= ',I16,',    N*(N+1)/2 = ',I16)
99991 FORMAT (' ** There have been at least MAXFEV calls to FCN: MAXFE',
     *       'V = ',I16)
99990 FORMAT (' ** No further improvement in the solution is possible.',
     *       /' ** XTOL is too small: XTOL = ',1P,D13.5)
      END

      DOUBLE PRECISION FUNCTION F06EJF( N, X, INCX )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     .. Entry Points ..
      DOUBLE PRECISION          DNRM2
      ENTRY                     DNRM2 ( N, X, INCX )
C     .. Scalar Arguments ..
      INTEGER                           INCX, N
C     .. Array Arguments ..
      DOUBLE PRECISION                  X( * )
C     ..
C
C  F06EJF returns the euclidean norm of a vector via the function
C  name, so that
C
C     F06EJF := sqrt( x'*x )
C
C
C  Nag Fortran 77 version of the Blas routine DNRM2.
C  Nag Fortran 77 O( n ) basic linear algebra routine.
C
C  -- Written on 25-October-1982.
C     Sven Hammarling, Nag Central Office.
C
C
C     .. Parameters ..
      DOUBLE PRECISION      ONE         , ZERO
      PARAMETER           ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION      NORM, SCALE, SSQ
C     .. External Functions ..
      DOUBLE PRECISION      F06BMF
      EXTERNAL              F06BMF
C     .. External Subroutines ..
      EXTERNAL              F06FJF
C     .. Intrinsic Functions ..
      INTRINSIC             ABS
C     ..
C     .. Executable Statements ..
      IF( N.LT.1 )THEN
         NORM  = ZERO
      ELSE IF( N.EQ.1 )THEN
         NORM  = ABS( X( 1 ) )
      ELSE
         SCALE = ZERO
         SSQ   = ONE
         CALL F06FJF( N, X, INCX, SCALE, SSQ )
         NORM  = F06BMF( SCALE, SSQ )
      END IF
C
      F06EJF = NORM
      RETURN
C
C     End of F06EJF. ( DNRM2 )
C
      END

      DOUBLE PRECISION FUNCTION F06BMF( SCALE, SSQ )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     .. Scalar Arguments ..
      DOUBLE PRECISION                  SCALE, SSQ
C     ..
C
C  F06BMF returns the value norm given by
C
C     norm = ( scale*sqrt( ssq ), scale*sqrt( ssq ) .lt. flmax
C            (
C            ( flmax,             scale*sqrt( ssq ) .ge. flmax
C
C  via the function name.
C
C
C  Nag Fortran 77 O( 1 ) basic linear algebra routine.
C
C  -- Written on 22-October-1982.
C     Sven Hammarling, Nag Central Office.
C
C
C     .. Local Scalars ..
      DOUBLE PRECISION      FLMAX, FLMIN, NORM, SQT
      LOGICAL               FIRST
C     .. External Functions ..
      DOUBLE PRECISION      X02AMF
      EXTERNAL              X02AMF
C     .. Intrinsic Functions ..
      INTRINSIC             SQRT
C     .. Save statement ..
      SAVE                  FIRST, FLMAX
C     .. Data statements ..
      DATA                  FIRST/ .TRUE. /
C     ..
C     .. Executable Statements ..
      IF( FIRST )THEN
         FIRST = .FALSE.
         FLMIN =  X02AMF( )
         FLMAX =  1/FLMIN
      END IF
C
      SQT = SQRT( SSQ )
      IF( SCALE.LT.FLMAX/SQT )THEN
         NORM = SCALE*SQT
      ELSE
         NORM = FLMAX
      END IF
C
      F06BMF = NORM
      RETURN
C
C     End of F06BMF. ( SNORM )
C
      END

      SUBROUTINE F06FJF( N, X, INCX, SCALE, SUMSQ )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     .. Scalar Arguments ..
      DOUBLE PRECISION   SCALE, SUMSQ
      INTEGER            INCX, N
C     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
C     ..
C
C  F06FJF returns the values scl and smsq such that
C
C     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
C
C  where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is assumed
C  to be at least unity and the value of smsq will then satisfy
C
C     1.0 .le. smsq .le. ( sumsq + n ) .
C
C  scale is assumed to be non-negative and scl returns the value
C
C     scl = max( scale, abs( x( i ) ) ) .
C
C  scale and sumsq must be supplied in SCALE and SUMSQ respectively.
C  scl and smsq are overwritten on SCALE and SUMSQ respectively.
C
C  The routine makes only one pass through the vector X.
C
C
C  Nag Fortran 77 O( n ) basic linear algebra routine.
C
C  -- Written on 22-October-1982.
C     Sven Hammarling, Nag Central Office.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   ABSXI
      INTEGER            IX
C     .. Intrinsic Functions ..
      INTRINSIC          ABS
C     ..
C     .. Executable Statements ..
      IF( N.GT.0 )THEN
         DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
            IF( X( IX ).NE.ZERO )THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI )THEN
                  SUMSQ = 1     + SUMSQ*( SCALE/ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SUMSQ = SUMSQ +       ( ABSXI/SCALE )**2
               END IF
            END IF
   10    CONTINUE
      END IF
      RETURN
C
C     End of F06FJF. ( SSSQ )
C
      END

      SUBROUTINE C05NCS(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG,MODE,
     *                  FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR,QTF,
     *                  WA1,WA2,WA3,WA4)
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     **********
C
C     SUBROUTINE C05NCS (based on MINPACK routine HYBRD )
C
C     The purpose of C05NCS is to find a zero of a system of
C     N nonlinear functions in N variables by a modification
C     of the Powell hybrid method. The user must provide a
C     subroutine which calculates the functions. The Jacobian is
C     then calculated by a forward-difference approximation.
C
C     **********
C
C     Revised to call BLAS.
C     P.J.D. Mayes, J.J. Du Croz, NAG Central Office, September 1987.
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, P1, P5, P001, P0001, ZERO
      PARAMETER         (ONE=1.0D0,P1=0.1D0,P5=0.5D0,P001=0.001D0,
     *                  P0001=0.0001D0,ZERO=0.0D0)
C     .. Scalar Arguments ..
      DOUBLE PRECISION  EPSFCN, FACTOR, XTOL
      INTEGER           INFO, LDFJAC, LR, MAXFEV, ML, MODE, MU, N, NFEV,
     *                  NPRINT
C     .. Array Arguments ..
      DOUBLE PRECISION  DIAG(N), FJAC(LDFJAC,N), FVEC(N), QTF(N), R(LR),
     *                  WA1(N), WA2(N), WA3(N), WA4(N), X(N)
C     .. Subroutine Arguments ..
      EXTERNAL          FCN
C     .. Local Scalars ..
      DOUBLE PRECISION  ACTRED, DELTA, EPSMCH, FNORM, FNORM1, PNORM,
     *                  PRERED, RATIO, SUM, TEMP, XNORM
      INTEGER           I, IFLAG, ITER, J, JM1, L, MSUM, NCFAIL, NCSUC,
     *                  NSLOW1, NSLOW2
      LOGICAL           JEVAL, SING
C     .. External Functions ..
      DOUBLE PRECISION  F06EJF, X02AJF
      EXTERNAL          F06EJF, X02AJF
C     .. External Subroutines ..
      EXTERNAL          C05NCU, C05NCV, C05NCW, C05NCX, C05NCY, C05NCZ,
     *                  DGEMV, DTPMV
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN, MOD
C     .. Executable Statements ..
      EPSMCH = X02AJF()
C
      INFO = 1
      IFLAG = 0
      NFEV = 0
C
C     Check the input parameters for errors.
C
      IF (MODE.EQ.2) THEN
         DO 20 J = 1, N
            IF (DIAG(J).LE.ZERO) GO TO 380
   20    CONTINUE
      END IF
C
C     Evaluate the function at the starting point
C     and calculate its norm.
C
      IFLAG = 1
      CALL FCN(N,X,FVEC,IFLAG)
      NFEV = 1
      IF (IFLAG.LT.0) GO TO 380
      FNORM = F06EJF(N,FVEC,1)
C
C     Determine the number of calls to FCN needed to compute
C     the Jacobian matrix.
C
      MSUM = MIN(ML+MU+1,N)
C
C     Initialize iteration counter and monitors.
C
      ITER = 1
      NCSUC = 0
      NCFAIL = 0
      NSLOW1 = 0
      NSLOW2 = 0
C
C     Beginning of the outer loop.
C
   40 CONTINUE
      JEVAL = .TRUE.
C
C     Calculate the Jacobian matrix.
C
      IFLAG = 2
      CALL C05NCV(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1,WA2)
      NFEV = NFEV + MSUM
      IF (IFLAG.LT.0) GO TO 380
C
C     Compute the QR factorization of the Jacobian.
C
      CALL C05NCX(N,FJAC,LDFJAC,WA1,WA2)
C
C     On the first iteration and if MODE is 1, scale according
C     to the norms of the columns of the initial Jacobian.
C
      IF (ITER.EQ.1) THEN
         IF (MODE.NE.2) THEN
            DO 60 J = 1, N
               DIAG(J) = WA2(J)
               IF (WA2(J).EQ.ZERO) DIAG(J) = ONE
   60       CONTINUE
         END IF
C
C        On the first iteration, calculate the norm of the scaled X
C        and initialize the step bound DELTA.
C
         DO 80 J = 1, N
            WA3(J) = DIAG(J)*X(J)
   80    CONTINUE
         XNORM = F06EJF(N,WA3,1)
         DELTA = FACTOR*XNORM
         IF (DELTA.EQ.ZERO) DELTA = FACTOR
      END IF
C
C           T
C     form Q *FVEC and store in QTF.
C
      DO 100 I = 1, N
         QTF(I) = FVEC(I)
  100 CONTINUE
      DO 160 J = 1, N
         IF (FJAC(J,J).NE.ZERO) THEN
            SUM = ZERO
            DO 120 I = J, N
               SUM = SUM + FJAC(I,J)*QTF(I)
  120       CONTINUE
            TEMP = -SUM/FJAC(J,J)
            DO 140 I = J, N
               QTF(I) = QTF(I) + FJAC(I,J)*TEMP
  140       CONTINUE
         END IF
  160 CONTINUE
C
C     Copy the triangular factor of the QR factorization into R.
C
      SING = .FALSE.
      DO 200 J = 1, N
         L = J
         JM1 = J - 1
         IF (JM1.GE.1) THEN
            DO 180 I = 1, JM1
               R(L) = FJAC(I,J)
               L = L + N - I
  180       CONTINUE
         END IF
         R(L) = WA1(J)
         IF (WA1(J).EQ.ZERO) SING = .TRUE.
  200 CONTINUE
C
C     Accumulate the orthogonal factor in FJAC.
C
      CALL C05NCW(N,FJAC,LDFJAC,WA1)
C
C     Rescale if necessary.
C
      IF (MODE.NE.2) THEN
         DO 220 J = 1, N
            DIAG(J) = MAX(DIAG(J),WA2(J))
  220    CONTINUE
      END IF
C
C     Beginning of the inner loop.
C
  240 CONTINUE
C
C     If requested, call FCN to enable printing of iterates.
C
      IF (NPRINT.GT.0) THEN
         IFLAG = 0
         IF (MOD(ITER-1,NPRINT).EQ.0) CALL FCN(N,X,FVEC,IFLAG)
         IF (IFLAG.LT.0) GO TO 380
      END IF
C
C     Determine the direction P.
C
      CALL C05NCU(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
C
C     Store the direction P and X + P. Calculate the norm of P.
C
      DO 260 J = 1, N
         WA1(J) = -WA1(J)
         WA2(J) = X(J) + WA1(J)
         WA3(J) = DIAG(J)*WA1(J)
  260 CONTINUE
      PNORM = F06EJF(N,WA3,1)
C
C     On the first iteration, adjust the initial step bound.
C
      IF (ITER.EQ.1) DELTA = MIN(DELTA,PNORM)
C
C     Evaluate the function at X + P and calculate its norm.
C
      IFLAG = 1
      CALL FCN(N,WA2,WA4,IFLAG)
      NFEV = NFEV + 1
      IF (IFLAG.LT.0) GO TO 380
      FNORM1 = F06EJF(N,WA4,1)
C
C     Compute the scaled actual reduction.
C
      ACTRED = -ONE
      IF (FNORM1.LT.FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
C
C     Compute the scaled predicted reduction.
C
      DO 280 I = 1, N
         WA3(I) = WA1(I)
  280 CONTINUE
      CALL DTPMV('Lower triangle','Transpose','Non-unit diagonal',N,R,
     *           WA3,1)
      DO 300 I = 1, N
         WA3(I) = WA3(I) + QTF(I)
  300 CONTINUE
      TEMP = F06EJF(N,WA3,1)
      PRERED = 1.0D0
      IF (TEMP.LT.FNORM) PRERED = ONE - (TEMP/FNORM)**2
C
C     Compute the ratio of the actual to the predicted
C     reduction.
C
      RATIO = ZERO
      IF (PRERED.GT.ZERO) RATIO = ACTRED/PRERED
C
C     Update the step bound.
C
      IF (RATIO.LT.P1) THEN
         NCSUC = 0
         NCFAIL = NCFAIL + 1
         DELTA = P5*DELTA
      ELSE
         NCFAIL = 0
         NCSUC = NCSUC + 1
         IF (RATIO.GE.P5 .OR. NCSUC.GT.1) DELTA = MAX(DELTA,PNORM/P5)
         IF (ABS(RATIO-ONE).LE.P1) DELTA = PNORM/P5
      END IF
C
C     Test for successful iteration.
C
      IF (RATIO.GE.P0001) THEN
C
C        Successful iteration. Update X, FVEC, and their norms.
C
         DO 320 J = 1, N
            X(J) = WA2(J)
            WA2(J) = DIAG(J)*X(J)
            FVEC(J) = WA4(J)
  320    CONTINUE
         XNORM = F06EJF(N,WA2,1)
         FNORM = FNORM1
         ITER = ITER + 1
      END IF
C
C     Determine the progress of the iteration.
C
      NSLOW1 = NSLOW1 + 1
      IF (ACTRED.GE.P001) NSLOW1 = 0
      IF (JEVAL) NSLOW2 = NSLOW2 + 1
      IF (ACTRED.GE.P1) NSLOW2 = 0
C
C     Test for convergence.
C
      IF (DELTA.LE.XTOL*XNORM .OR. FNORM.EQ.ZERO .OR. PNORM.EQ.ZERO)
     *    INFO = 0
      IF (INFO.NE.1) GO TO 380
C
C     Tests for termination and stringent tolerances.
C
      IF (NFEV.GE.MAXFEV) INFO = 2
      IF (DELTA.LE.EPSMCH*XNORM) INFO = 3
      IF (NSLOW2.EQ.5) INFO = 4
      IF (NSLOW1.EQ.10) INFO = 5
      IF (INFO.NE.1) GO TO 380
C
C     Criterion for recalculating Jacobian approximation
C     by forward differences.
C
      IF (NCFAIL.NE.2) THEN
C
C        Calculate the rank one modification to the Jacobian
C        and update QTF if necessary.
C
         CALL DGEMV('Transpose',N,N,ONE,FJAC,LDFJAC,WA4,1,ZERO,WA2,1)
         IF (RATIO.GE.P0001) THEN
            DO 340 J = 1, N
               QTF(J) = WA2(J)
  340       CONTINUE
         END IF
         DO 360 J = 1, N
            WA2(J) = (WA2(J)-WA3(J))/PNORM
            WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
  360    CONTINUE
C
C        Compute the QR factorization of the updated Jacobian.
C
         CALL C05NCZ(N,N,R,LR,WA1,WA2,WA3,SING)
         CALL C05NCY(N,N,FJAC,LDFJAC,WA2,WA3)
         CALL C05NCY(1,N,QTF,1,WA2,WA3)
C
C        End of the inner loop.
C
         JEVAL = .FALSE.
         GO TO 240
      END IF
C
C     End of the outer loop.
C
      GO TO 40
  380 CONTINUE
C
C     Termination, either normal or user imposed.
C
      IF (IFLAG.LT.0) INFO = IFLAG
      IFLAG = 0
      IF (NPRINT.GT.0) CALL FCN(N,X,FVEC,IFLAG)
      RETURN
      END

      SUBROUTINE C05NCU(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     MARK 14C REVISED. IER-869 (NOV 1990).
C     **********
C
C     SUBROUTINE C05NCU (based on MINPACK routine DOGLEG)
C
C     Given an M by N matrix A, an N by N nonsingular diagonal
C     matrix D, an M-vector B, and A positive number DELTA, the
C     problem is to determine the convex combination X of the
C     Gauss-Newton and scaled gradient directions that minimizes
C     (A*X - B) in the least squares sense, subject to the
C     restriction that the euclidean norm of D*X be at most DELTA.
C
C     This subroutine completes the solution of the problem
C     if it is provided with the necessary information from the
C     QR factorization of A. That is, if A = Q*R, where Q has
C     orthogonal columns and R is an upper triangular matrix,
C     then C05NCU expects the full upper triangle of R and
C     the first N components of (Q transpose)*B.
C
C     The subroutine statement is
C
C     SUBROUTINE C05NCU(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
C
C     where
C
C     N is a positive integer input variable set to the order of R.
C
C     R is an input array of length LR which must contain the upper
C     triangular matrix R stored by rows.
C
C     LR is a positive integer input variable not less than
C     (N*(N+1))/2.
C
C     DIAG is an input array of length N which must contain the
C     diagonal elements of the matrix D.
C
C     QTB is an input array of length N which must contain the first
C     N elements of the vector (Q transpose)*B.
C
C     DELTA is a positive input variable which specifies an upper
C     bound on the Euclidean norm of D*X.
C
C     X is an output array of length N which contains the desired
C     convex combination of the Gauss-Newton direction and the
C     scaled gradient direction.
C
C     WA1 and WA2 are work arrays of length N.
C
C     Argonne National Laboratory. MINPACK project. March 1980.
C     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
C
C     **********
C
C     Revised to call BLAS.
C     P.J.D. Mayes, J.J. Du Croz, NAG Central Office, September 1987.
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         (ONE=1.0D0,ZERO=0.0D0)
C     .. Scalar Arguments ..
      DOUBLE PRECISION  DELTA
      INTEGER           LR, N
C     .. Array Arguments ..
      DOUBLE PRECISION  DIAG(N), QTB(N), R(LR), WA1(N), WA2(N), X(N)
C     .. Local Scalars ..
      DOUBLE PRECISION  ALPHA, BNORM, EPSMCH, GNORM, QNORM, SGNORM, TEMP
      INTEGER           I, J, JJ, L
C     .. External Functions ..
      DOUBLE PRECISION  F06EJF, X02AJF
      EXTERNAL          F06EJF, X02AJF
C     .. External Subroutines ..
      EXTERNAL          DTPMV, DTPSV
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN, SQRT
C     .. Executable Statements ..
      EPSMCH = X02AJF()
C
C     First, calculate the Gauss-Newton direction.
C
      JJ = 1
      DO 40 J = 1, N
         WA1(J) = R(JJ)
         IF (R(JJ).EQ.ZERO) THEN
            TEMP = ZERO
            L = J
            DO 20 I = 1, J - 1
               TEMP = MAX(TEMP,ABS(R(L)))
               L = L + N - I
   20       CONTINUE
            IF (TEMP.EQ.ZERO) THEN
               R(JJ) = EPSMCH
            ELSE
               R(JJ) = EPSMCH*TEMP
            END IF
         END IF
         JJ = JJ + N - J + 1
   40 CONTINUE
      DO 60 I = 1, N
         X(I) = QTB(I)
   60 CONTINUE
      CALL DTPSV('Lower triangle','Transpose','Non-unit diagonal',N,R,X,
     *           1)
      JJ = 1
      DO 80 J = 1, N
         R(JJ) = WA1(J)
         JJ = JJ + N - J + 1
   80 CONTINUE
C
C     Test whether the Gauss-Newton direction is acceptable.
C
      DO 100 J = 1, N
         WA2(J) = DIAG(J)*X(J)
  100 CONTINUE
      QNORM = F06EJF(N,WA2,1)
      IF (QNORM.GT.DELTA) THEN
C
C        The Gauss-Newton direction is not acceptable.
C        next, calculate the scaled gradient direction.
C
         DO 120 I = 1, N
            WA1(I) = QTB(I)
  120    CONTINUE
         CALL DTPMV('Lower triangle','Not transpose',
     *              'Non-unit diagonal',N,R,WA1,1)
         DO 140 I = 1, N
            WA1(I) = WA1(I)/DIAG(I)
  140    CONTINUE
C
C        Calculate the norm of the scaled gradient and test for
C        the special case in which the scaled gradient is zero.
C
         GNORM = F06EJF(N,WA1,1)
         SGNORM = ZERO
         ALPHA = DELTA/QNORM
         IF (GNORM.NE.ZERO) THEN
C
C           Calculate the point along the scaled gradient
C           at which the quadratic is minimized.
C
            DO 160 J = 1, N
               WA1(J) = (WA1(J)/GNORM)/DIAG(J)
  160       CONTINUE
            DO 180 I = 1, N
               WA2(I) = WA1(I)
  180       CONTINUE
            CALL DTPMV('Lower triangle','Transpose','Non-unit diagonal',
     *                 N,R,WA2,1)
            TEMP = F06EJF(N,WA2,1)
            SGNORM = (GNORM/TEMP)/TEMP
C
C           Test whether the scaled gradient direction is acceptable.
C
            ALPHA = ZERO
            IF (SGNORM.LT.DELTA) THEN
C
C              The scaled gradient direction is not acceptable.
C              Finally, calculate the point along the dogleg
C              at which the quadratic is minimized.
C
               BNORM = F06EJF(N,QTB,1)
               TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA)
               TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 +
     *                SQRT((TEMP-(DELTA/QNORM))**2+(ONE-(DELTA/QNORM)
     *                **2)*(ONE-(SGNORM/DELTA)**2))
               ALPHA = ((DELTA/QNORM)*(ONE-(SGNORM/DELTA)**2))/TEMP
            END IF
         END IF
C
C        Form appropriate convex combination of the Gauss-Newton
C        direction and the scaled gradient direction.
C
         TEMP = (ONE-ALPHA)*MIN(SGNORM,DELTA)
         DO 200 J = 1, N
            X(J) = TEMP*WA1(J) + ALPHA*X(J)
  200    CONTINUE
      END IF
      RETURN
      END

      SUBROUTINE C05NCV(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1,
     *                  WA2)
C     MARK 9 RELEASE.  NAG COPYRIGHT 1981
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988).
C     **********
C
C     SUBROUTINE C05NCV(BASED ON MINPACK ROUTINE FDJAC1)
C
C     THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION
C     TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED
C     PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS
C     A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY
C     APPROXIMATING THE NONZERO TERMS.
C
C     THE SUBROUTINE STATEMENT IS
C
C     SUBROUTINE C05NCV(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
C     WA1,WA2)
C
C     WHERE
C
C     FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
C     CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
C     IN AN EXTERNAL STATEMENT IN THE USER CALLING
C     PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
C
C     SUBROUTINE FCN(N,X,FVEC,IFLAG)
C     INTEGER N,IFLAG
C     REAL X(N),FVEC(N)
C     ----------
C     CALCULATE THE FUNCTIONS AT X AND
C     RETURN THIS VECTOR IN FVEC.
C     ----------
C     RETURN
C     END
C
C     THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
C     THE USER WANTS TO TERMINATE EXECUTION OF C05NCV.
C     IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
C
C     N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C     OF FUNCTIONS AND VARIABLES.
C
C     X IS AN INPUT ARRAY OF LENGTH N.
C
C     FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
C     FUNCTIONS EVALUATED AT X.
C
C     FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
C     APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
C
C     LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
C     WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
C
C     IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
C     THE EXECUTION OF C05NCV. SEE DESCRIPTION OF FCN.
C
C     ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
C     THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE
C     JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
C     ML TO AT LEAST N - 1.
C
C     EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
C     STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
C     APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
C     FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
C     THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
C     ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
C     PRECISION.
C
C     MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
C     THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE
C     JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
C     MU TO AT LEAST N - 1.
C
C     WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT
C     LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS
C     NOT REFERENCED.
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
C
C     EPSMCH IS THE MACHINE PRECISION.
C
C     FCN
C     .. Scalar Arguments ..
      DOUBLE PRECISION  EPSFCN
      INTEGER           IFLAG, LDFJAC, ML, MU, N
C     .. Array Arguments ..
      DOUBLE PRECISION  FJAC(LDFJAC,N), FVEC(N), WA1(N), WA2(N), X(N)
C     .. Subroutine Arguments ..
      EXTERNAL          FCN
C     .. Local Scalars ..
      DOUBLE PRECISION  EPS, EPSMCH, H, TEMP, ZERO
      INTEGER           I, J, K, MSUM
C     .. External Functions ..
      DOUBLE PRECISION  X02AJF
      EXTERNAL          X02AJF
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, SQRT
C     .. Data statements ..
      DATA              ZERO/0.0D0/
C     .. Executable Statements ..
      EPSMCH = X02AJF()
C
      EPS = SQRT(MAX(EPSFCN,EPSMCH))
      MSUM = ML + MU + 1
      IF (MSUM.LT.N) GO TO 80
C
C     COMPUTATION OF DENSE APPROXIMATE JACOBIAN.
C
      DO 40 J = 1, N
         TEMP = X(J)
         H = EPS*ABS(TEMP)
         IF (H.EQ.ZERO) H = EPS
         X(J) = TEMP + H
         CALL FCN(N,X,WA1,IFLAG)
         IF (IFLAG.LT.0) GO TO 60
         X(J) = TEMP
         DO 20 I = 1, N
            FJAC(I,J) = (WA1(I)-FVEC(I))/H
   20    CONTINUE
   40 CONTINUE
   60 CONTINUE
      GO TO 200
   80 CONTINUE
C
C     COMPUTATION OF BANDED APPROXIMATE JACOBIAN.
C
      DO 160 K = 1, MSUM
         DO 100 J = K, N, MSUM
            WA2(J) = X(J)
            H = EPS*ABS(WA2(J))
            IF (H.EQ.ZERO) H = EPS
            X(J) = WA2(J) + H
  100    CONTINUE
         CALL FCN(N,X,WA1,IFLAG)
         IF (IFLAG.LT.0) GO TO 180
         DO 140 J = K, N, MSUM
            X(J) = WA2(J)
            H = EPS*ABS(WA2(J))
            IF (H.EQ.ZERO) H = EPS
            DO 120 I = 1, N
               FJAC(I,J) = ZERO
               IF (I.GE.J-MU .AND. I.LE.J+ML) FJAC(I,J) = (WA1(I)
     *             -FVEC(I))/H
  120       CONTINUE
  140    CONTINUE
  160 CONTINUE
  180 CONTINUE
  200 CONTINUE
      RETURN
      END

      SUBROUTINE C05NCW(N,Q,LDQ,WA)
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     **********
C
C     SUBROUTINE C05NCW (based on MINPACK routine QFORM )
C
C     This subroutine proceeds from the computed QR factorization of
C     an N by N matrix A to accumulate the N by N orthogonal matrix
C     Q from its factored form.
C
C     The subroutine statement is
C
C        SUBROUTINE C05NCW(N,Q,LDQ,WA)
C
C     where
C
C     N is a positive integer input variable set to the number
C     of rows and columns of A and the order of Q.
C
C     Q is an N by N array. On input the full lower trapezoid in
C     the first N columns of Q contains the factored form.
C     On output Q has been accumulated into a square matrix.
C
C     LDQ is a positive integer input variable not less than N
C     which specifies the leading dimension of the array Q.
C
C     WA is a work array of length N.
C
C     Argonne National Laboratory. MINPACK project. March 1980.
C     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
C
C     **********
C
C     Revised to call BLAS.
C     P.J.D. Mayes, J.J. Du Croz, NAG Central Office, September 1987.
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         (ONE=1.0D0,ZERO=0.0D0)
C     .. Scalar Arguments ..
      INTEGER           LDQ, N
C     .. Array Arguments ..
      DOUBLE PRECISION  Q(LDQ,N), WA(N)
C     .. Local Scalars ..
      INTEGER           I, J, K, LDQ1
C     .. External Subroutines ..
      EXTERNAL          DGEMV, DGER
C     .. Executable Statements ..
      DO 40 J = 2, N
         DO 20 I = 1, J - 1
            Q(I,J) = ZERO
   20    CONTINUE
   40 CONTINUE
C
C     Accumulate Q from its factored form.
C
      DO 80 K = N, 1, -1
         IF (Q(K,K).NE.ZERO .AND. K.NE.N) THEN
            IF (K.EQ.N-1) THEN
               LDQ1 = 2
            ELSE
               LDQ1 = LDQ
            END IF
            CALL DGEMV('Transpose',N-K+1,N-K,ONE,Q(K,K+1),LDQ1,Q(K,K),1,
     *                 ZERO,WA(K+1),1)
            CALL DGER(N-K+1,N-K,-ONE/Q(K,K),Q(K,K),1,WA(K+1),1,Q(K,K+1),
     *                LDQ1)
         END IF
         DO 60 I = K + 1, N
            Q(I,K) = -Q(I,K)
   60    CONTINUE
         Q(K,K) = ONE - Q(K,K)
   80 CONTINUE
C
      RETURN
      END

      SUBROUTINE C05NCX(N,A,LDA,RDIAG,ACNORM)
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     **********
C
C     SUBROUTINE C05NCX (Based on MINPACK routine QRFAC )
C
C     This subroutine uses householder transformations to compute a QR
C     factorization of the N by N matrix A. That is, C05NCX determines
C     an orthogonal matrix Q, and an upper triangular matrix R such
C     that A = Q*R. The Householder transformation for column K, K =
C     1,2,...,N, is of the form
C
C                     T
C     I - (1/U(K))*U*U
C
C     where U has zeros in the first K-1 positions. The form of this
C     transformation first appeared in the corresponding LINPACK
C     subroutine.
C
C     The subroutine statement is
C
C        SUBROUTINE C05NCX(N,A,LDA,RDIAG,ACNORM)
C
C     where
C
C     N is a positive integer input variable set to the number
C     of rows and columns of A.
C
C     A is an N by N array. On input A contains the matrix for
C     which the QR factorization is to be computed. On output
C     the strict upper triangular part of a contains the strict
C     upper triangular part of R, and the lower triangular
C     part of a contains a factored form of Q (the non-trivial
C     elements of the U vectors described above).
C
C     LDA is a positive integer input variable not less than N
C     which specifies the leading dimension of the array A.
C
C     RDIAG is an output array of length N which contains the
C     diagonal elements of R.
C
C     ACNORM is an output array of length N which contains the
C     norms of the corresponding columns of the input matrix A.
C
C     Argonne National Laboratory. MINPACK Project. March 1980.
C     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
C
C     **********
C
C     Revised to call BLAS.
C     P.J.D. Mayes, J.J. Du Croz, NAG Central Office, September 1987.
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         (ONE=1.0D0,ZERO=0.0D0)
C     .. Scalar Arguments ..
      INTEGER           LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,N), ACNORM(N), RDIAG(N)
C     .. Local Scalars ..
      DOUBLE PRECISION  AJNORM, EPSMCH
      INTEGER           I, J, LDA1
C     .. External Functions ..
      DOUBLE PRECISION  F06EJF, X02AJF
      EXTERNAL          F06EJF, X02AJF
C     .. External Subroutines ..
      EXTERNAL          DGEMV, DGER
C     .. Executable Statements ..
      EPSMCH = X02AJF()
C
C     Compute the intial column norms
C
      DO 20 J = 1, N
         ACNORM(J) = F06EJF(N,A(1,J),1)
   20 CONTINUE
C
C     Reduce A to R with Householder transformations.
C
      LDA1 = LDA
      DO 60 J = 1, N
C
C        Compute the Householder transformation to reduce the
C        J-th column of A to a multiple of the J-th unit vector.
C
         AJNORM = F06EJF(N-J+1,A(J,J),1)
         IF (AJNORM.NE.ZERO) THEN
            IF (A(J,J).LT.ZERO) AJNORM = -AJNORM
            DO 40 I = J, N
               A(I,J) = A(I,J)/AJNORM
   40       CONTINUE
            A(J,J) = A(J,J) + ONE
            IF (J.NE.N) THEN
               IF (J.EQ.N-1) LDA1 = 2
               CALL DGEMV('Transpose',N-J+1,N-J,ONE,A(J,J+1),LDA1,A(J,J)
     *                    ,1,ZERO,RDIAG(J+1),1)
               CALL DGER(N-J+1,N-J,-ONE/A(J,J),A(J,J),1,RDIAG(J+1),1,
     *                   A(J,J+1),LDA1)
            END IF
         END IF
         RDIAG(J) = -AJNORM
   60 CONTINUE
      RETURN
      END

      SUBROUTINE C05NCY(M,N,A,LDA,V,W)
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     **********
C
C     SUBROUTINE C05NCY (based on MINPACK routine R1MPYQ)
C
C     Given an M by N matrix A, this subroutine computes A*Q where
C     Q is the product of 2*(N - 1) transformations
C
C        GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     and GV(I), GW(I) are Givens rotations in the (I,N) plane which
C     eliminate elements in the I-th and N-th planes, respectively.
C     Q itself is not given, rather the information to recover the
C     GV, GW rotations is supplied.
C
C     The subroutine statement is
C
C        SUBROUTINE C05NCY(M,N,A,LDA,V,W)
C
C     where
C
C     M is a positive integer input variable set to the number
C     of rows of A.
C
C     N is a positive integer input variable set to the number
C     of columns of A.
C
C     A is an M by N array. On input A must contain the matrix
C     to be postmultiplied by the orthogonal matrix Q
C     described above. On output A*Q has replaced A.
C
C     LDA is a positive integer input variable not less than M
C     which specifies the leading dimension of the array A.
C
C     V is an input array of length N. V(I) must contain the
C     information necessary to recover the Givens rotation GV(I)
C     described above.
C
C     W is an input array of length N. W(I) must contain the
C     information necessary to recover the Givens rotation GW(I)
C     described above.
C
C     Argonne National Laboratory. MINPACK Project. March 1980.
C     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
C
C     **********
C
C     Revised to call BLAS.
C     P.J.D. Mayes, J.J. Du Croz, NAG Central Office, September 1987.
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         (ONE=1.0D0)
C     .. Scalar Arguments ..
      INTEGER           LDA, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,N), V(N), W(N)
C     .. Local Scalars ..
      DOUBLE PRECISION  COSINE, SINE
      INTEGER           J, NM1, NMJ
C     .. External Subroutines ..
      EXTERNAL          DROT
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Executable Statements ..
C
C     Apply the first set of Givens rotations to A.
C
      NM1 = N - 1
      IF (NM1.GE.1) THEN
         DO 20 NMJ = 1, NM1
            J = N - NMJ
            IF (ABS(V(J)).GT.ONE) THEN
               COSINE = ONE/V(J)
               SINE = SQRT(ONE-COSINE**2)
            ELSE
               SINE = V(J)
               COSINE = SQRT(ONE-SINE**2)
            END IF
            CALL DROT(M,A(1,N),1,A(1,J),1,COSINE,SINE)
   20    CONTINUE
C
C        Apply the second set of Givens rotations to A.
C
         DO 40 J = 1, NM1
            IF (ABS(W(J)).GT.ONE) THEN
               COSINE = ONE/W(J)
               SINE = SQRT(ONE-COSINE**2)
            ELSE
               SINE = W(J)
               COSINE = SQRT(ONE-SINE**2)
            END IF
            CALL DROT(M,A(1,J),1,A(1,N),1,COSINE,SINE)
   40    CONTINUE
      END IF
      RETURN
      END

      SUBROUTINE C05NCZ(M,N,S,LS,U,V,W,SING)
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     **********
C
C     SUBROUTINE C05NCZ (based on MINPACK Routine R1UPDT)
C
C     Given an M by N lower trapezoidal matrix S, an M-vector U,
C     and an N-vector V, the problem is to determine an
C     orthogonal matrix Q such that
C
C             T
C     (S + U*V )*Q
C
C     is again lower trapezoidal.
C
C     This subroutine determines Q as the product of 2*(N - 1)
C     transformations
C
C        GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     where GV(I), GW(I) are Givens rotations in the (I,N) plane
C     which eliminate elements in the I-th and N-th planes,
C     respectively. Q itself is not accumulated, rather the
C     information to recover the GV, GW rotations is returned.
C
C     The subroutine statement is
C
C        SUBROUTINE C05NCZ(M,N,S,LS,U,V,W,SING)
C
C     where
C
C     M is a positive integer input variable set to the number
C     of rows of S.
C
C     N is a positive integer input variable set to the number
C     of columns of S. N must not exceed M.
C
C     S is an array of length LS. On input S must contain the lower
C     trapezoidal matrix S stored by columns. On output S contains
C     the lower trapezoidal matrix produced as described above.
C
C     LS is a positive integer input variable not less than
C     (N*(2*M-N+1))/2.
C
C     U is an input array of length M which must contain the
C     vector U.
C
C     V is an array of length N. On input V must contain the vector
C     V. On output V(I) contains the information necessary to
C     recover the Givens rotation GV(I) described above.
C
C     W is an output array of length M. W(I) contains information
C     necessary to recover the Givens rotation GW(I) described
C     above.
C
C     SING is a logical output variable. SING is set .TRUE. if any
C     of the diagonal elements of the output S are zero. Otherwise
C     SING is set .FALSE.
C
C     Argonne National Laboratory. MINPACK project. March 1980.
C     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More,
C     John L. Nazareth
C
C     **********
C
C     Revised to call BLAS.
C     P.J.D. Mayes, J.J. Du Croz, NAG Central Office, September 1987.
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, P5, P25, ZERO
      PARAMETER         (ONE=1.0D0,P5=0.5D0,P25=0.25D0,ZERO=0.0D0)
C     .. Scalar Arguments ..
      INTEGER           LS, M, N
      LOGICAL           SING
C     .. Array Arguments ..
      DOUBLE PRECISION  S(LS), U(M), V(N), W(M)
C     .. Local Scalars ..
      DOUBLE PRECISION  COSINE, COTAN, GIANT, SINE, TANGNT, TAU
      INTEGER           I, J, JJ, L, NM1, NMJ
C     .. External Functions ..
      DOUBLE PRECISION  X02ALF
      EXTERNAL          X02ALF
C     .. External Subroutines ..
      EXTERNAL          DROT
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Executable Statements ..
      GIANT = X02ALF()
C
C     Initialize the diagonal element pointer.
C
      JJ = (N*(2*M-N+1))/2 - (M-N)
C
C     Move the nontrivial part of the last column of S into W.
C
      L = JJ
      DO 20 I = N, M
         W(I) = S(L)
         L = L + 1
   20 CONTINUE
C
C     Rotate the vector V into a multiple of the N-th unit vector
C     in such a way that a spike is introduced into W.
C
      NM1 = N - 1
      IF (NM1.GE.1) THEN
         DO 60 NMJ = 1, NM1
            J = N - NMJ
            JJ = JJ - (M-J+1)
            W(J) = ZERO
            IF (V(J).EQ.ZERO) GO TO 40
C
C           Determine a Givens rotation which eliminates the
C           J-th element of V.
C
            IF (ABS(V(N)).LT.ABS(V(J))) THEN
               COTAN = V(N)/V(J)
               SINE = P5/SQRT(P25+P25*COTAN**2)
               COSINE = SINE*COTAN
               TAU = ONE
               IF (ABS(COSINE)*GIANT.GT.ONE) TAU = ONE/COSINE
            ELSE
               TANGNT = V(J)/V(N)
               COSINE = P5/SQRT(P25+P25*TANGNT**2)
               SINE = COSINE*TANGNT
               TAU = SINE
            END IF
C
C           Apply the transformation to V and store the information
C           necessary to recover the Givens rotation.
C
            V(N) = SINE*V(J) + COSINE*V(N)
            V(J) = TAU
C
C           Apply the transformation to S and extend the spike in W.
C
            CALL DROT(M-J+1,W(J),1,S(JJ),1,COSINE,SINE)
   40       CONTINUE
   60    CONTINUE
      END IF
C
C     Add the spike from the rank 1 update to W.
C
      DO 80 I = 1, M
         W(I) = W(I) + V(N)*U(I)
   80 CONTINUE
C
C     Eliminate the spike.
C
      SING = .FALSE.
      IF (NM1.GE.1) THEN
         DO 100 J = 1, NM1
            IF (W(J).NE.ZERO) THEN
C
C              Determine a Givens rotation which eliminates the
C              J-th element of the spike.
C
               IF (ABS(S(JJ)).LT.ABS(W(J))) THEN
                  COTAN = S(JJ)/W(J)
                  SINE = P5/SQRT(P25+P25*COTAN**2)
                  COSINE = SINE*COTAN
                  TAU = ONE
                  IF (ABS(COSINE)*GIANT.GT.ONE) TAU = ONE/COSINE
               ELSE
                  TANGNT = W(J)/S(JJ)
                  COSINE = P5/SQRT(P25+P25*TANGNT**2)
                  SINE = COSINE*TANGNT
                  TAU = SINE
               END IF
C
C              Apply the transformation to S and reduce the spike in W.
C
               CALL DROT(M-J+1,S(JJ),1,W(J),1,COSINE,SINE)
C
C              Store the information necessary to recover the
C              Givens rotation.
C
               W(J) = TAU
            END IF
C
C           Test for zero diagonal elements in the output S.
C
            IF (S(JJ).EQ.ZERO) SING = .TRUE.
            JJ = JJ + (M-J+1)
  100    CONTINUE
      END IF
C
C     Move W back into the last column of the output S.
C
      L = JJ
      DO 120 I = N, M
         S(L) = W(I)
         L = L + 1
  120 CONTINUE
      IF (S(JJ).EQ.ZERO) SING = .TRUE.
      RETURN
      END

      SUBROUTINE F06PHF( UPLO, TRANS, DIAG, N, AP, X, INCX )
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     .. Entry Points ..
      ENTRY      DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
C     .. Scalar Arguments ..
      INTEGER            INCX, N
      CHARACTER*1        DIAG, TRANS, UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
C     ..
C
C  Purpose
C  =======
C
C  DTPMV  performs one of the matrix-vector operations
C
C     x := A*x,   or   x := A'*x,
C
C  where x is n element vector and A is an n by n unit, or non-unit,
C  upper or lower triangular matrix.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the matrix is an upper or
C           lower triangular matrix as follows:
C
C              UPLO = 'U' or 'u'   A is an upper triangular matrix.
C
C              UPLO = 'L' or 'l'   A is a lower triangular matrix.
C
C           Unchanged on exit.
C
C  TRANS  - CHARACTER*1.
C           On entry, TRANS specifies the operation to be performed as
C           follows:
C
C              TRANS = 'N' or 'n'   x := A*x.
C
C              TRANS = 'T' or 't'   x := A'*x.
C
C              TRANS = 'C' or 'c'   x := A'*x.
C
C           Unchanged on exit.
C
C  DIAG   - CHARACTER*1.
C           On entry, DIAG specifies whether or not A is unit
C           triangular as follows:
C
C              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
C
C              DIAG = 'N' or 'n'   A is not assumed to be unit
C                                  triangular.
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with  UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular matrix packed sequentially,
C           column by column, so that AP( 1 ) contains a( 1, 1 ),
C           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
C           respectively, and so on.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular matrix packed sequentially,
C           column by column, so that AP( 1 ) contains a( 1, 1 ),
C           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
C           respectively, and so on.
C           Note that when  DIAG = 'U' or 'u', the diagonal elements of
C           A are not referenced, but are assumed to be unity.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the n
C           element vector x. On exit, X is overwritten with the
C           tranformed vector x.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
      LOGICAL            NOUNIT
C     .. External Subroutines ..
      EXTERNAL           F06AAZ
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.(UPLO .EQ.'U' .OR. UPLO .EQ.'u').AND.
     $         .NOT.(UPLO .EQ.'L' .OR. UPLO .EQ.'l')      )THEN
         INFO = 1
      ELSE IF( .NOT.(TRANS.EQ.'N' .OR. TRANS.EQ.'n').AND.
     $         .NOT.(TRANS.EQ.'T' .OR. TRANS.EQ.'t').AND.
     $         .NOT.(TRANS.EQ.'C' .OR. TRANS.EQ.'c')      )THEN
         INFO = 2
      ELSE IF( .NOT.(DIAG .EQ.'U' .OR. DIAG .EQ.'u').AND.
     $         .NOT.(DIAG .EQ.'N' .OR. DIAG .EQ.'n')      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL F06AAZ( 'F06PHF/DTPMV ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      NOUNIT = (DIAG.EQ.'N' .OR. DIAG.EQ.'n')
C
C     Set up the start point in X if the increment is not unity. This
C     will be  ( N - 1 )*INCX  too small for descending loops.
C
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
C
C     Start the operations. In this version the elements of AP are
C     accessed sequentially with one pass through AP.
C
      IF( (TRANS.EQ.'N' .OR. TRANS.EQ.'n') )THEN
C
C        Form  x:= A*x.
C
         IF( (UPLO.EQ.'U' .OR. UPLO.EQ.'u') )THEN
            KK =1
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     K    = KK
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*AP( K )
                        K      = K      + 1
   10                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*AP( KK + J - 1 )
                  END IF
                  KK = KK + J
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, K = KK, KK + J - 2
                        X( IX ) = X( IX ) + TEMP*AP( K )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*AP( KK + J - 1 )
                  END IF
                  JX = JX + INCX
                  KK = KK + J
   40          CONTINUE
            END IF
         ELSE
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     K    = KK
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*AP( K )
                        K      = K      - 1
   50                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*AP( KK - N + J )
                  END IF
                  KK = KK - ( N - J + 1 )
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1
                        X( IX ) = X( IX ) + TEMP*AP( K )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*AP( KK - N + J )
                  END IF
                  JX = JX - INCX
                  KK = KK - ( N - J + 1 )
   80          CONTINUE
            END IF
         END IF
      ELSE
C
C        Form  x := A'*x.
C
         IF( (UPLO.EQ.'U' .OR. UPLO.EQ.'u') )THEN
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  K = KK - 1
                  DO 90, I = J - 1, 1, -1
                     TEMP = TEMP + AP( K )*X( I )
                     K    = K    - 1
   90             CONTINUE
                  X( J ) = TEMP
                  KK     = KK   - J
  100          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  DO 110, K = KK - 1, KK - J + 1, -1
                     IX   = IX   - INCX
                     TEMP = TEMP + AP( K )*X( IX )
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  KK      = KK   - J
  120          CONTINUE
            END IF
         ELSE
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  K = KK + 1
                  DO 130, I = J + 1, N
                     TEMP = TEMP + AP( K )*X( I )
                     K    = K    + 1
  130             CONTINUE
                  X( J ) = TEMP
                  KK     = KK   + ( N - J + 1 )
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  DO 150, K = KK + 1, KK + N - J
                     IX   = IX   + INCX
                     TEMP = TEMP + AP( K )*X( IX )
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  KK      = KK   + ( N - J + 1 )
  160          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of F06PHF (DTPMV ).
C
      END

      SUBROUTINE F06PAF( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     AXP4 VERSION FOR VECTOR MACHINES
C     .. Entry Points ..
      ENTRY      DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, LDA, M, N
      CHARACTER*1        TRANS
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
C     ..
C
C  Purpose
C  =======
C
C  DGEMV  performs one of the matrix-vector operations
C
C     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
C
C  where alpha and beta are scalars, x and y are vectors and A is an
C  m by n matrix.
C
C  Parameters
C  ==========
C
C  TRANS  - CHARACTER*1.
C           On entry, TRANS specifies the operation to be performed as
C           follows:
C
C              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
C
C              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
C
C              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
C
C           Unchanged on exit.
C
C  M      - INTEGER.
C           On entry, M specifies the number of rows of the matrix A.
C           M must be at least zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the number of columns of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
C           Before entry, the leading m by n part of the array A must
C           contain the matrix of coefficients.
C           Unchanged on exit.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program. LDA must be at least
C           max( 1, m ).
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of DIMENSION at least
C           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
C           and at least
C           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
C           Before entry, the incremented array X must contain the
C           vector x.
C           Unchanged on exit.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C  BETA   - DOUBLE PRECISION.
C           On entry, BETA specifies the scalar beta. When BETA is
C           supplied as zero then Y need not be set on input.
C           Unchanged on exit.
C
C  Y      - DOUBLE PRECISION array of DIMENSION at least
C           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
C           and at least
C           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
C           Before entry with BETA non-zero, the incremented array Y
C           must contain the vector y. On exit, Y is overwritten by the
C           updated vector y.
C
C  INCY   - INTEGER.
C           On entry, INCY specifies the increment for the elements of
C           Y. INCY must not be zero.
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C  -- DO-loops unrolled on 20-November-1986.
C     Peter Mayes, Nag Central Office.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP, TEMP1, TEMP2, TEMP3, TEMP4
      INTEGER            I, INFO, IY, J, JX, KX, KY, LENX, LENY, M4, N4
C     .. External Subroutines ..
      EXTERNAL           F06AAZ
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.(TRANS.EQ.'N' .OR. TRANS.EQ.'n').AND.
     $         .NOT.(TRANS.EQ.'T' .OR. TRANS.EQ.'t').AND.
     $         .NOT.(TRANS.EQ.'C' .OR. TRANS.EQ.'c')      )THEN
         INFO = 1
      ELSE IF( M.LT.0 )THEN
         INFO = 2
      ELSE IF( N.LT.0 )THEN
         INFO = 3
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL F06AAZ( 'F06PAF/DGEMV ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
C     up the start points in  X  and  Y.
C
      IF( (TRANS.EQ.'N' .OR. TRANS.EQ.'n') )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
C
C     Start the operations. In this version the inner loops are all
C     equivalent to AXPY operations.
C
C     First form  y := beta*y.
C
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )
     $   RETURN
      JX = KX
      IF( (TRANS.EQ.'N' .OR. TRANS.EQ.'n') )THEN
C
C        Form  y := alpha*A*x + y.
C
         IF( INCY.EQ.1 )THEN
C**** U n r o l l   t o   d e p t h   4 ********************************
            N4 = 4*( N/4 )
            DO 60, J = 1, N4, 4
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ALPHA*X( JX + INCX )
               TEMP3 = ALPHA*X( JX + 2*INCX )
               TEMP4 = ALPHA*X( JX + 3*INCX )
               IF( TEMP1.NE.ZERO.OR.TEMP2.NE.ZERO.OR.TEMP3.NE.ZERO.OR.
     $             TEMP4.NE.ZERO )THEN
                  DO 50, I = 1, M
                     Y( I ) = ( ( ( ( Y( I ) + TEMP1*A( I, J ) )
     $                        + TEMP2*A( I, J + 1 ) )
     $                        + TEMP3*A( I, J + 2 ) )
     $                        + TEMP4*A( I, J + 3 ) )
   50             CONTINUE
               END IF
               JX = JX + 4*INCX
   60       CONTINUE
C**** Clean-up loop ****************************************************
            DO 80, J = N4 + 1, N, 1
               TEMP = ALPHA*X( JX )
               IF( TEMP.NE.ZERO )THEN
                  DO 70, I = 1, M
                     Y( I ) = Y( I ) + TEMP*A( I, J )
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         ELSE
C**** U n r o l l   t o   d e p t h   4 ********************************
            N4 = 4*( N/4 )
            DO 100, J = 1, N4, 4
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ALPHA*X( JX + INCX )
               TEMP3 = ALPHA*X( JX + 2*INCX )
               TEMP4 = ALPHA*X( JX + 3*INCX )
               IF( TEMP1.NE.ZERO.OR.TEMP2.NE.ZERO.OR.TEMP3.NE.ZERO.OR.
     $             TEMP4.NE.ZERO )THEN
                  IY = KY
                  DO 90, I = 1, M
                     Y( IY ) = ( ( ( ( Y( IY ) + TEMP1*A( I, J ) )
     $                         + TEMP2*A( I, J + 1 ) )
     $                         + TEMP3*A( I, J + 2 ) )
     $                         + TEMP4*A( I, J + 3 ) )
                     IY = IY + INCY
   90             CONTINUE
               END IF
               JX = JX + 4*INCX
  100       CONTINUE
C**** Clean-up loop ****************************************************
            DO 120, J = N4 + 1, N, 1
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY = KY
                  DO 110, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
                     IY = IY + INCY
  110             CONTINUE
               END IF
               JX = JX + INCX
  120       CONTINUE
         END IF
      ELSE
C
C        Form  y := alpha*A'*x + y.
C
         IF( INCY.EQ.1 )THEN
C**** U n r o l l   t o   d e p t h   4 ********************************
            M4 = 4*( M/4 )
            DO 140, J = 1, M4, 4
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ALPHA*X( JX + INCX )
               TEMP3 = ALPHA*X( JX + 2*INCX )
               TEMP4 = ALPHA*X( JX + 3*INCX )
               IF( TEMP1.NE.ZERO.OR.TEMP2.NE.ZERO.OR.TEMP3.NE.ZERO.OR.
     $             TEMP4.NE.ZERO )THEN
                  DO 130, I = 1, N
                     Y( I ) = ( ( ( ( Y( I ) + TEMP1*A( J, I ) )
     $                        + TEMP2*A( J + 1, I ) )
     $                        + TEMP3*A( J + 2, I ) )
     $                        + TEMP4*A( J + 3, I ) )
  130             CONTINUE
               END IF
               JX = JX + 4*INCX
  140       CONTINUE
C**** Clean-up loop ****************************************************
            DO 160, J = M4 + 1, M, 1
               TEMP = ALPHA*X( JX )
               IF( TEMP.NE.ZERO )THEN
                  DO 150, I = 1, N
                     Y( I ) = Y( I ) + TEMP*A( J, I )
  150             CONTINUE
               END IF
               JX = JX + INCX
  160       CONTINUE
         ELSE
C**** U n r o l l   t o   d e p t h   4 ********************************
            M4 = 4*( M/4 )
            DO 180, J = 1, M4, 4
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ALPHA*X( JX + INCX )
               TEMP3 = ALPHA*X( JX + 2*INCX )
               TEMP4 = ALPHA*X( JX + 3*INCX )
               IF( TEMP1.NE.ZERO.OR.TEMP2.NE.ZERO.OR.TEMP3.NE.ZERO.OR.
     $             TEMP4.NE.ZERO )THEN
                  IY = KY
                  DO 170, I = 1, N
                     Y( IY ) = ( ( ( ( Y( IY ) + TEMP1*A( J, I ) )
     $                         + TEMP2*A( J + 1, I ) )
     $                         + TEMP3*A( J + 2, I ) )
     $                         + TEMP4*A( J + 3, I ) )
                     IY = IY + INCY
  170             CONTINUE
               END IF
               JX = JX + 4*INCX
  180       CONTINUE
C**** Clean-up loop ****************************************************
            DO 200, J = M4 + 1, M, 1
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY = KY
                  DO 190, I = 1, N
                     Y( IY ) = Y( IY ) + TEMP*A( J, I )
                     IY = IY + INCY
  190             CONTINUE
               END IF
               JX = JX + INCX
  200       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of F06PAF (DGEMV ).
C
      END

      SUBROUTINE F06EPF( N, X, INCX, Y, INCY, C, S )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     .. Entry Points ..
      ENTRY      DROT  ( N, X, INCX, Y, INCY, C, S )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   C, S
      INTEGER            INCX, INCY, N
C     .. Array Arguments ..
      DOUBLE PRECISION   X( * ), Y( * )
C     ..
C
C  F06EPF performs the plane rotation
C
C     ( x  y ) = ( x  y )*( c  -s ).
C                         ( s   c )
C
C
C  Nag Fortran 77 version of the Blas routine DROT.
C  Nag Fortran 77 O( n ) basic linear algebra routine.
C
C  -- Written on 23-January-1984.
C     Sven Hammarling, Nag Central Office.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1
      INTEGER            I, IX, IY
C     ..
C     .. Executable Statements ..
      IF( N.GT.0 )THEN
         IF( ( S.NE.ZERO ).OR.( C.NE.ONE ) )THEN
            IF( ( C.EQ.ZERO ).AND.( S.EQ.ONE ) )THEN
               IF( ( INCX.EQ.INCY ).AND.( INCX.GT.0 ) )THEN
                  DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
                     TEMP1   = -X( IX )
                     X( IX ) =  Y( IX )
                     Y( IX ) =  TEMP1
   10             CONTINUE
               ELSE
                  IF( INCY.GE.0 )THEN
                     IY = 1
                  ELSE
                     IY = 1 - ( N - 1 )*INCY
                  END IF
                  IF( INCX.GT.0 )THEN
                     DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX
                        TEMP1   = -X( IX )
                        X( IX ) =  Y( IY )
                        Y( IY ) =  TEMP1
                        IY      =  IY       + INCY
   20                CONTINUE
                  ELSE
                     IX = 1 - ( N - 1 )*INCX
                     DO 30, I = 1, N
                        TEMP1   = -X( IX )
                        X( IX ) =  Y( IY )
                        Y( IY ) =  TEMP1
                        IX      =  IX      + INCX
                        IY      =  IY      + INCY
   30                CONTINUE
                  END IF
               END IF
            ELSE IF( ( C.EQ.ZERO ).AND.( S.EQ.( -ONE ) ) )THEN
               IF( ( INCX.EQ.INCY ).AND.( INCX.GT.0 ) )THEN
                  DO 40, IX = 1, 1 + ( N - 1 )*INCX, INCX
                     TEMP1   =  X( IX )
                     X( IX ) = -Y( IX )
                     Y( IX ) =  TEMP1
   40             CONTINUE
               ELSE
                  IF( INCY.GE.0 )THEN
                     IY = 1
                  ELSE
                     IY = 1 - ( N - 1 )*INCY
                  END IF
                  IF( INCX.GT.0 )THEN
                     DO 50, IX = 1, 1 + ( N - 1 )*INCX, INCX
                        TEMP1   =  X( IX )
                        X( IX ) = -Y( IY )
                        Y( IY ) =  TEMP1
                        IY      =  IY       + INCY
   50                CONTINUE
                  ELSE
                     IX = 1 - ( N - 1 )*INCX
                     DO 60, I = 1, N
                        TEMP1   =  X( IX )
                        X( IX ) = -Y( IY )
                        Y( IY ) =  TEMP1
                        IX      =  IX      + INCX
                        IY      =  IY      + INCY
   60                CONTINUE
                  END IF
               END IF
            ELSE
               IF( ( INCX.EQ.INCY ).AND.( INCX.GT.0 ) )THEN
                  DO 70, IX = 1, 1 + ( N - 1 )*INCX, INCX
                     TEMP1   = X( IX )
                     X( IX ) = S*Y( IX ) + C*TEMP1
                     Y( IX ) = C*Y( IX ) - S*TEMP1
   70             CONTINUE
               ELSE
                  IF( INCY.GE.0 )THEN
                     IY = 1
                  ELSE
                     IY = 1 - ( N - 1 )*INCY
                  END IF
                  IF( INCX.GT.0 )THEN
                     DO 80, IX = 1, 1 + ( N - 1 )*INCX, INCX
                        TEMP1   = X( IX )
                        X( IX ) = S*Y( IY ) + C*TEMP1
                        Y( IY ) = C*Y( IY ) - S*TEMP1
                        IY      = IY        + INCY
   80                CONTINUE
                  ELSE
                     IX = 1 - ( N - 1 )*INCX
                     DO 90, I = 1, N
                        TEMP1   = X( IX )
                        X( IX ) = S*Y( IY ) + C*TEMP1
                        Y( IY ) = C*Y( IY ) - S*TEMP1
                        IX      = IX        + INCX
                        IY      = IY        + INCY
   90                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of F06EPF. ( DROT )
C
      END

      SUBROUTINE F06PMF( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     .. Entry Points ..
      ENTRY      DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
C     ..
C
C  Purpose
C  =======
C
C  DGER   performs the rank 1 operation
C
C     A := alpha*x*y' + A,
C
C  where alpha is a scalar, x is an m element vector, y is an n element
C  vector and A is an m by n matrix.
C
C  Parameters
C  ==========
C
C  M      - INTEGER.
C           On entry, M specifies the number of rows of the matrix A.
C           M must be at least zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the number of columns of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( m - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the m
C           element vector x.
C           Unchanged on exit.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C  Y      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCY ) ).
C           Before entry, the incremented array Y must contain the n
C           element vector y.
C           Unchanged on exit.
C
C  INCY   - INTEGER.
C           On entry, INCY specifies the increment for the elements of
C           Y. INCY must not be zero.
C           Unchanged on exit.
C
C  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
C           Before entry, the leading m by n part of the array A must
C           contain the matrix of coefficients. On exit, A is
C           overwritten by the updated matrix.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program. LDA must be at least
C           max( 1, m ).
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JY, KX
C     .. External Subroutines ..
      EXTERNAL           F06AAZ
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL F06AAZ( 'F06PMF/DGER  ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
     $   RETURN
C
C     Start the operations. In this version the elements of A are
C     accessed sequentially with one pass through A.
C
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
C
      RETURN
C
C     End of F06PMF (DGER  ).
C
      END

      SUBROUTINE F06PLF( UPLO, TRANS, DIAG, N, AP, X, INCX )
C     MARK 13 RE-ISSUE. NAG COPYRIGHT 1988.
C     .. Entry Points ..
      ENTRY      DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
C     .. Scalar Arguments ..
      INTEGER            INCX, N
      CHARACTER*1        DIAG, TRANS, UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
C     ..
C
C  Purpose
C  =======
C
C  DTPSV  solves one of the systems of equations
C
C     A*x = b,   or   A'*x = b,
C
C  where b and x are n element vectors and A is an n by n unit, or
C  non-unit, upper or lower triangular matrix.
C
C  No test for singularity or near-singularity is included in this
C  routine. Such tests must be performed before calling this routine.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the matrix is an upper or
C           lower triangular matrix as follows:
C
C              UPLO = 'U' or 'u'   A is an upper triangular matrix.
C
C              UPLO = 'L' or 'l'   A is a lower triangular matrix.
C
C           Unchanged on exit.
C
C  TRANS  - CHARACTER*1.
C           On entry, TRANS specifies the equations to be solved as
C           follows:
C
C              TRANS = 'N' or 'n'   A*x = b.
C
C              TRANS = 'T' or 't'   A'*x = b.
C
C              TRANS = 'C' or 'c'   A'*x = b.
C
C           Unchanged on exit.
C
C  DIAG   - CHARACTER*1.
C           On entry, DIAG specifies whether or not A is unit
C           triangular as follows:
C
C              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
C
C              DIAG = 'N' or 'n'   A is not assumed to be unit
C                                  triangular.
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with  UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular matrix packed sequentially,
C           column by column, so that AP( 1 ) contains a( 1, 1 ),
C           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
C           respectively, and so on.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular matrix packed sequentially,
C           column by column, so that AP( 1 ) contains a( 1, 1 ),
C           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
C           respectively, and so on.
C           Note that when  DIAG = 'U' or 'u', the diagonal elements of
C           A are not referenced, but are assumed to be unity.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the n
C           element right-hand side vector b. On exit, X is overwritten
C           with the solution vector x.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
      LOGICAL            NOUNIT
C     .. External Subroutines ..
      EXTERNAL           F06AAZ
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.(UPLO .EQ.'U' .OR. UPLO .EQ.'u').AND.
     $         .NOT.(UPLO .EQ.'L' .OR. UPLO .EQ.'l')      )THEN
         INFO = 1
      ELSE IF( .NOT.(TRANS.EQ.'N' .OR. TRANS.EQ.'n').AND.
     $         .NOT.(TRANS.EQ.'T' .OR. TRANS.EQ.'t').AND.
     $         .NOT.(TRANS.EQ.'C' .OR. TRANS.EQ.'c')      )THEN
         INFO = 2
      ELSE IF( .NOT.(DIAG .EQ.'U' .OR. DIAG .EQ.'u').AND.
     $         .NOT.(DIAG .EQ.'N' .OR. DIAG .EQ.'n')      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL F06AAZ( 'F06PLF/DTPSV ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      NOUNIT = (DIAG.EQ.'N' .OR. DIAG.EQ.'n')
C
C     Set up the start point in X if the increment is not unity. This
C     will be  ( N - 1 )*INCX  too small for descending loops.
C
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
C
C     Start the operations. In this version the elements of AP are
C     accessed sequentially with one pass through AP.
C
      IF( (TRANS.EQ.'N' .OR. TRANS.EQ.'n') )THEN
C
C        Form  x := inv( A )*x.
C
         IF( (UPLO.EQ.'U' .OR. UPLO.EQ.'u') )THEN
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/AP( KK )
                     TEMP = X( J )
                     K    = KK     - 1
                     DO 10, I = J - 1, 1, -1
                        X( I ) = X( I ) - TEMP*AP( K )
                        K      = K      - 1
   10                CONTINUE
                  END IF
                  KK = KK - J
   20          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 40, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/AP( KK )
                     TEMP = X( JX )
                     IX   = JX
                     DO 30, K = KK - 1, KK - J + 1, -1
                        IX      = IX      - INCX
                        X( IX ) = X( IX ) - TEMP*AP( K )
   30                CONTINUE
                  END IF
                  JX = JX - INCX
                  KK = KK - J
   40          CONTINUE
            END IF
         ELSE
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/AP( KK )
                     TEMP = X( J )
                     K    = KK     + 1
                     DO 50, I = J + 1, N
                        X( I ) = X( I ) - TEMP*AP( K )
                        K      = K      + 1
   50                CONTINUE
                  END IF
                  KK = KK + ( N - J + 1 )
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/AP( KK )
                     TEMP = X( JX )
                     IX   = JX
                     DO 70, K = KK + 1, KK + N - J
                        IX      = IX      + INCX
                        X( IX ) = X( IX ) - TEMP*AP( K )
   70                CONTINUE
                  END IF
                  JX = JX + INCX
                  KK = KK + ( N - J + 1 )
   80          CONTINUE
            END IF
         END IF
      ELSE
C
C        Form  x := inv( A' )*x.
C
         IF( (UPLO.EQ.'U' .OR. UPLO.EQ.'u') )THEN
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  K    = KK
                  DO 90, I = 1, J - 1
                     TEMP = TEMP - AP( K )*X( I )
                     K    = K    + 1
   90             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK + J - 1 )
                  X( J ) = TEMP
                  KK     = KK   + J
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  DO 110, K = KK, KK + J - 2
                     TEMP = TEMP - AP( K )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK + J - 1 )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  KK      = KK   + J
  120          CONTINUE
            END IF
         ELSE
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  K = KK
                  DO 130, I = N, J + 1, -1
                     TEMP = TEMP - AP( K )*X( I )
                     K    = K    - 1
  130             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK - N + J )
                  X( J ) = TEMP
                  KK     = KK   - ( N - J + 1 )
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1
                     TEMP = TEMP - AP( K )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK - N + J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  KK      = KK   - (N - J + 1 )
  160          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of F06PLF (DTPSV ).
C
      END

      SUBROUTINE F06AAZ ( SRNAME, INFO )
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C     .. Scalar Arguments ..
      INTEGER            INFO
      CHARACTER*13       SRNAME
C     ..
C
C  Purpose
C  =======
C
C  F06AAZ  is an error handler for the Level 2 BLAS routines.
C
C  It is called by the Level 2 BLAS routines if an input parameter is
C  invalid.
C
C  Parameters
C  ==========
C
C  SRNAME - CHARACTER*13.
C           On entry, SRNAME specifies the name of the routine which
C           called F06AAZ.
C
C  INFO   - INTEGER.
C           On entry, INFO specifies the position of the invalid
C           parameter in the parameter-list of the calling routine.
C
C
C  Auxiliary routine for Level 2 Blas.
C
C  Written on 20-July-1986.
C
C     .. Local Scalars ..
      INTEGER            IFAIL
      CHARACTER*80       REC (1)
C     .. External Functions ..
      INTEGER            P01ABF
      EXTERNAL           P01ABF
C     ..
C     .. Executable Statements ..
      WRITE (REC (1),99999) SRNAME, INFO
      IFAIL = 0
      IFAIL = P01ABF (IFAIL, -1, SRNAME(1:6), 1, REC)
C
      RETURN
C
99999 FORMAT ( ' ** On entry to ', A13, ' parameter number ', I2,
     $         ' had an illegal value' )
C
C     End of F06AAZ.
C
      END

      DOUBLE PRECISION FUNCTION X02ALF()
C     MARK 12 RELEASE. NAG COPYRIGHT 1986.
C
C     RETURNS  (1 - B**(-P)) * B**EMAX  (THE LARGEST POSITIVE MODEL
C     NUMBER)
C
      DOUBLE PRECISION X02CON
      DATA X02CON /1.79769313486231D+308 /
C     .. Executable Statements ..
      X02ALF = X02CON
      RETURN
      END

      SUBROUTINE X04ABF(I,NADV)
C     MARK 7 RELEASE. NAG COPYRIGHT 1978
C     MARK 7C REVISED IER-190 (MAY 1979)
C     MARK 11.5(F77) REVISED. (SEPT 1985.)
C     MARK 14 REVISED. IER-830 (DEC 1989).
C      IF I = 0, SETS NADV TO CURRENT ADVISORY MESSAGE UNIT NUMBER
C     (STORED IN NADV1).
C     IF I = 1, CHANGES CURRENT ADVISORY MESSAGE UNIT NUMBER TO
C     VALUE SPECIFIED BY NADV.
C
C     .. Scalar Arguments ..
      INTEGER           I, NADV
C     .. Local Scalars ..
      INTEGER           NADV1
C     .. Save statement ..
      SAVE              NADV1
C     .. Data statements ..
      DATA              NADV1/6/
C     .. Executable Statements ..
      IF (I.EQ.0) NADV = NADV1
      IF (I.EQ.1) NADV1 = NADV
      RETURN
      END
